COMMENT ⊗   VALID 00032 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002
C00007 00003	 FORMAT OF FASL FILES:
C00022 00004
C00023 00005
C00026 00006
C00032 00007
C00035 00008
C00039 00009
C00044 00010
C00047 00011
C00050 00012
C00053 00013
C00057 00014
C00063 00015
C00067 00016
C00070 00017
C00073 00018
C00076 00019
C00078 00020
C00080 00021
C00084 00022
C00087 00023
C00090 00024
C00093 00025
C00095 00026
C00097 00027
C00098 00028
C00100 00029
C00103 00030
C00105 00031
C00107 00032
C00111 ENDMK
C⊗;

;;;   -*-MIDAS-*-
;;;   **************************************************************
;;;   ***** MACLISP ****** FASLOAD  ********************************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1978 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************

	PGBOT FSL

SUBTTL	HAIRY RELOCATING LOADER (FASLOAD)

;;; BUFFER PARAMETERS
Q% 10%	LLDBF==:100		;LENGTH OF LOADER'S BINARY INPUT BUFFER ARRAY
Q% 10$ SA$ 	LLDBF==:1401
Q% 10$ SA%	LLDBF==:1401
LLDAT==:770		;LENGTH OF LOADER'S ATOMTABLE ARRAY
ILDAT==:1000		;AMOUNT TO INCREMENT ATOMTABLE ARRAY
LLDSTB==:400		;SIZE OF LDPUT'S SYMBOL TABLE ARRAY (IN 2-WD ENTRIES)

;;; PDL OFFSETS
IFE QIO,[
LDAGEN==:0		;SAR FOR ATOMTABLE
LDBGEN==:-1		;SAR FOR I/O BUFFER
LDPRLS==:-2		;PURE CLOBBERING LIST
LDDDTP==:-3		;DDT FLAG
]		;END OF IFE QIO
.ELSE,[
LDAGEN==:0		;SAR FOR ATOMTABLE
LDPRLS==:-1		;PURE CLOBBERING LIST
LDDDTP==:-2		;DDT FLAG
LDBGEN==:-3		;SAR FOR I/O BUFFER
]		;END OF .ELSE
LDNPDS==:4		;NUMBER OF REGPDL SLOTS TAKE UP BY FASLOAD TEMPORARIES

;;; FASLOAD USES AN ARRAY OF ATOMS TO AVOID CONSTANTLY CREATING
;;; THE SAME ATOMS OVER AND OVER; IN PARTICULAR, THIS SAVES MUCH
;;; TIME IN INTERN FOR ATOMIC SYMBOLS. THIS TABLE IS CREATED
;;; INCREMENTALLY DURING THE LOAD FROM DATA IN THE FASL FILE.  THE
;;; ARRAY HAS ONE ONE-WORD ENTRY FOR EACH ATOM. ENTRY 0 IS FOR NIL;
;;; THE OTHERS MAY BE IN ANY ORDER. THE FORMAT OF EACH ATOMTABLE
;;; ENTRY IS AS FOLLOWS: 
;;;	4.9-4.1	IF NON-ZERO, THE THE LEFT HALF OF THE ENTRY
;;;		(4.9-3.1) CONTAINS THE ADDRESS OF THE VALUE
;;;		CELL OF THE ATOM (SYMBOLS ONLY). THIS WORKS
;;;		BECAUSE ALL VALUE CELLS ARE ABOVE ADDRESS 777.
;;;		NOTE THAT OTHER LEFT HALF BITS DESCRIBED HERE
;;;		HAVE MEANING ONLY IF BITS 4.9-4.1 ARE ZERO.
;;;	3.4	THIS BIT IS TURNED ON IF THE ATOM IS PROTECTED
;;;		FROM THE GARBAGE COLLECTOR BECAUSE IT IS POINTED
;;;		BY SOME LIST STRUCTURE WHICH IS PROTECTED. THIS
;;;		IS A HACK SO THAT USELESS ENTRIES WON'T BE MADE
;;;		IN THE GC PROTECTION ARRAY (SEE GCPRO).
;;;	3.3-3.2	INDICATES THE TYPE OF ATOM: 0 => SYMBOL,
;;;		1 => FIXNUM, 2 => FLONUM, 3 => BIGNUM.
;;;	3.1	THIS BIT IS TURNED ON IF THE ATOM IS EVER
;;;		REFERENCED, DIRECTLY OR INDIRECTLY, BY COMPILED
;;;		CODE (IT MIGHT NOT BE IF USED ONLY IN MUNGABLES).
;;;		IT INDICATES THAT THE ATOM MUST SOMEHOW BE
;;;		PROTECTED FROM THE FEROCIOUS GARBAGE COLLECTOR.
;;;		2.9-1.1	CONTAINS THE ADDRESS OF THE ATOM. (SURPRISE!)
;;; NOTE THAT ONCE AN ATOM IS IN THE TABLE, THE FASL FILE WILL
;;; REFER TO THE ATOM BY ITS TABLE INDEX, SO THAT IT CAN BE
;;; RETRIEVED EXTREMELY QUICKLY.
;;; FORMAT OF FASL FILES:
;;;
;;; THE "NEW" FASLOAD SCHEME (AS OF 1/31/73) USES A NEW FORMAT FOR
;;; ITS FILES. A FASL FILE CONSISTS OF TWO HEADER WORDS, FOLLOWED BY
;;; A SERIES OF FASL BLOCKS; THE TWO HEADER WORDS ARE BOTH SIXBIT,
;;; THE FIRST BEING "*FASL+" (FOR HISTORICAL REASONS, "*FASL* IS
;;; ALSO ACCEPTED) AND THE SECOND THE CONTENTS OF LOCATION LDFNM2 IN
;;; THE LISP WHICH ASSEMBLED THE FILE (A VERSION NUMBER IN SIXBIT). 
;;; EACH FASL BLOCK CONSISTS OF A WORD OF NINE FOUR-BIT RELOCATION
;;; BYTES, FOLLOWED BY NINE PIECES OF FASL DATA.  THE LENGTH OF EACH
;;; DATA ITEM IS DEPENDENT ON THE RELOCATION TYPE; THUS FASLBLOCKS
;;; ARE OF VARYING LENGTH.  THE LAST BLOCK MAY HAVE FEWER THAN NINE
;;; DATA ITEMS.  THE RELOCATION TYPES AND THE FORMATS OF THE
;;; ASSOCIATED DATA ITEMS ARE AS FOLLOWS: 
;;;
;;;	TYPE 0	ABSOLUTE
;;; ONE ABSOLUTE WORD TO BE LOADED.
;;;
;;;	TYPE 1	RELOCATABLE
;;; ONE WORD, THE RIGHT HALF OF WHICH IS RELOCATABLE; I.E. AT LOAD
;;; TIME THE LOAD OFFSET IS TO BE ADDED TO THE RIGHT HALF. 
;;;
;;;	TYPE 2	SPECIAL
;;; A WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE INDEX OF AN
;;; ATOM (HOPEFULLY OF TYPE PNAME) THE ADDRESS OF THE VALUE CELL OF
;;; WHICH IS TO REPLACE THE RIGHT HALF OF THE LOADED WORD. (IF NO
;;; VALUE CELL EXISTS, ONE IS TO BE CREATED.)
;;;
;;;	TYPE 3	SMASHABLE CALL
;;; SIMILAR TO TYPE 4 (Q.V.) EXCEPT THAT THE INSTRUCTION IS ONE OF
;;; THE SERIES OF CALL UUOS WHICH MAY BE "SMASHED" FOR PURIFICATION
;;; PURPOSES. AT PRESENT THESE UUOS ARE: CALL, JCALL, NCALL, NJCALL. 
;;;
;;;	TYPE 4	QUOTED ATOM
;;; ONE WORD TO BE LOADED WHOSE RIGHT HALF CONTAINS THE INDEX OF AN
;;; ATOM WHOSE ADDRESS IS TO REPLACE THE RIGHT HALF OF THE WORD
;;; LOADED. 
;;;
;;;	TYPE 5	QUOTED LIST
;;; A SERIES OF WORDS REPRESENTING AN S-EXPRESSION TO BE CONSTRUCTED
;;; BY THE LOADER. THE FORMAT OF THESE WORDS IS BEST EXPLAINED BY
;;; THE ALGORITHM USED TO CONTRUCT THE S-EXPRESSION: THE LOADER
;;; EXAMINES BITS 4.7-4.9 OF SUCCESSIVELY READ WORDS, AND DISPATCHES
;;; ON THEM: 
;;; 0	THE ATOM WHOSE INDEX IS IN THE RIGHT HALF OF THE WORD
;;;	IS PUSHED ONTO A STACK. 
;;; 1	THE LOADER POPS AS MANY ITEMS OFF THE STACK AS
;;;	SPECIFIED BY THE NUMBER IN THE RIGHT HALF OF THE WORD
;;;	AND MAKES A LIST OF THEM, SO THAT THE LAST ITEM POPPED
;;;	BECOMES THE FIRST ITEM OF THE LIST; THIS LIST IS THEN
;;;	PUSHED ONTO THE STACK. 
;;; 2	THE LOADER POPS ONE ITEM OFF THE STACK AND PROCEEDS AS
;;;	FOR 1, EXCEPT THAT THE ITEM FIRST POPPED IS USED TO
;;;	END THE LIST INSTEAD IF NIL. (THIS ALLOWS FOR DOTTED
;;;	PAIRS.)
;;; 3	THE TOP ITEM ON THE STACK IS EVALUATED AND STORED BACK
;;;	ON THE TOP OF THE STACK. 
;;; 4	THE RIGHT HALF OR THE WORD SPECIFIES THE LENGTH OF A
;;;	HUNK TO BE MADE BY TAKING THAT MANY ITEMS FROM THE TOP
;;;	OF THE STACK;  THIS HUNK IS THEN PUSHED BACK. 
;;; 5	UNUSED.
;;; 6	UNUSED.
;;; 7	THE LEFT HALF OF THE WORD SHOULD BE -1 OR -2,
;;;	INDICATING THE SECOND LAST WORD OF THE DATA; IF -1,
;;;	THE RIGHT HALF OF THIS WORD AND THE ADDRESS OF (WHAT
;;;	SHOULD BE) THE SINGLE ITEM ON THE STACK (WHICH IS
;;;	POPPED OFF) ARE MADE RESPECTIVELY INTO THE LEFT AND
;;;	RIGHT HALVES OF A WORD TO BE LOADED INTO BINARY
;;;	PROGRAM SPACE; IF -2, THE S-EXPRESSION IS PLACED INTO
;;;	THE NEXT SLOT OF THE ATOMTABLE (SEE TYPE 12).  THE ONE
;;;	WORD REMAINING IS THE HASH KEY OF THE S-EXPRESSION AS
;;;	COMPUTED BY SXHASH; THIS IS USED BY THE LOADER TO SAVE
;;;	GCPRO SOME WORK. 
;;;
;;;	TYPE 6	GLOBALSYM
;;; ONE WORD; THE RIGHT HALF IS AN INDEX INTO THE TABLE LSYMS IN
;;; LISP. THE INDICATED VALUE IS RETRIEVED, NEGATED IF BIT 4.9 OF
;;; THE DATA WORD IS 1, AND ADDED TO THE RIGHT HALF OF THE LAST
;;; WORD LOADED INTO BINARY PROGRAM SPACE.  THIS ALLOWS LAP CODE
;;; TO REFER TO SELECTED LOCATIONS INTERNAL TO LISP WITHOUT
;;; GETTING SYMBOLS FROM DDT. 
;;;
;;;	TYPE 7	GETDDTSYM
;;; IF THE FIRST WORD IS -1, THEN THE LOAD OFFSET IF ADDED INTO
;;; THE LEFT HALF OF THE WORD MOST RECENTLY LOADED INTO BINARY
;;; PROGRAM SPACE (THIS IS HOW LEFT HALF RELOCATION IS
;;; ACCOMPLISHED).  OTHERWISE, THE FIRST WORD CONTAINS IN BITS
;;; 1.1-4.5 A SYMBOL IN SQUOZE CODE. THE LOADER GETS THE VALUE OF
;;; THIS SYMBOL FROM DDT IF POSSIBLE, NEGATES IT IF BIT 4.9 IS 1,
;;; THEN ADDS THE RESULT TO THE FIELD OF THE LAST WORD LOADED AS
;;; SPECIFIED BY BITS 4.6-4.7: 
;;;	3 = ENTIRE WORD
;;;	2 = AC FIELD ONLY
;;;	1 = RIGHT HALF ONLY
;;;	0 = ENTIRE WORD, BUT SWAP HALVES OF VALUE BEFORE ADDING.
;;; THESE FOUR FIELDS CORRESPOND TO OPCODE, AC, ADDRESS, AND INDEX
;;; FIELDS RESPECTIVELY IN A LAP INSTRUCTION.  IF BIT 4.8 IS A 1,
;;; THEN ANOTHER WORD FOLLOWS, CONTAINING THE VALUE OF THE SYMBOL
;;; AS OBTAINED FROM DDT AT ASSEMBLE TIME. IF THE VERSION NUMBER
;;; OF THAT LISP (AS DETERMINED FROM THE SECOND FILE HEADER WORD)
;;; IS THE SAME AS THAT OF THE LISP BEING LOADED INTO, THEN THIS
;;; VALUE IS USED AND DDT IS NOT CONSULTED AT LOAD TIME; THIS IS
;;; FOR SPEED. IF THE VERSION NUMBERS ARE DIFFERENT, THEN DDT IS
;;; CONSULTED. 
;;;
;;;	TYPE 10	ARRAY REFERENCE
;;; ONE WORD TO BE LOADED, WHOSE RIGHT HALF CONTAINS THE ATOMINDEX
;;; OF AN ATOMIC SYMBOL. IF THE SYMBOL HAS AN ARRAY PROPERTY, IT
;;; IS FETCHED; OTHERWISE ONE IS CREATED. THE RIGHT HALF OF THE
;;; WORD TO BE LOADED IS REPLACED WITH THE ADDRESS OF THE SECOND
;;; WORD OF THE ARRAY POINTER (I.E. OF THE TTSAR).  IN THIS WAY
;;; ACCESSES TO ARRAYS CAN BE OPEN-CODED. 
;;;
;;;	TYPE 11	UNUSED
;;;
;;;	TYPE 12	ATOMTABLE INFO
;;; A HEADER WORD, POSSIBLY FOLLOWED BY OTHERS, DEPENDING ON BITS
;;; 4.7-4.9: 
;;; 0	THE RIGHT HALF IS THE NUMBER OF WORDS FOLLOWING, WHICH
;;;	CONSTITUTE THE PNAME OF A PNAME-TYPE ATOM, IN THE
;;;	ORDER OF THEIR APPEARANCE ON A PROPERTY LIST. THE ATOM
;;;	IS INTERNED. 
;;; 1	THE ONE WORD FOLLOWING IS THE VALUE OF A FIXNUM TO BE
;;;	CREATED. 
;;; 2	THE FOLLOWING WORD IS THE VALUE OF A FLONUM. 
;;; 3	THE RIGHT HALF IS THE NUMBER OF FIXNUM COMPONENTS OF A
;;;	BIGNUM FOLLOWING, MOST SIGNIFICANT WORD FIRST.  BIT 3.1
;;;	IS THE SIGN OF THE BIGNUM.
;;; 4	THE FOLLOWING TWO WORDS ARE A DOUBLE-PRECISION NUMBER.
;;; 5	THE FOLLOWING TWO WORDS ARE A COMPLEX NUMBER.
;;; 6	THE FOLLOWING FOUR WORDS ARE A DUPLEX NUMBER.
;;; 7	UNUSED.
;;; THE ATOM THUS CREATED IS ASSIGNED A PLACE IN THE ATOMTABLE
;;; MAINTAINED BY THE LOADER (AS AN ARRAY) USING CONSECUTIVE
;;; LOCATIONS; FROM THAT POINT ON OTHER DATA ITEMS REFERRING TO
;;; THAT ITEM CAN DO SO BY THE INDEX OF THE ATOM IN THIS TABLE. 
;;; SEE ALSO TYPES 5 AND 16, WHICH ALSO MAKE ENTRIES IN THE
;;; ATOMTABLE. 
;;;
;;;	TYPE 13	ENTRY INFO
;;; TWO WORDS. THE LEFT HALF OF THE FIRST WORD IS THE ATOMINDEX
;;; OF THE NAME OF THE FUNCTION BEING DEFINED; THE RIGHT HALF
;;; THAT OF THE SUBR TYPE (THE PROPERTY UNDER WHICH TO CREATE THE
;;; ENTRY POINT, E.G. SUBR OR FSUBR).  THE RIGHT HALF OF THE
;;; SECOND WORD IS THE LOCATION OF THE ENTRY POINT AS A
;;; RELOCATABLE POINTER: THE LOAD OFFSET MUST BE ADDED TO IT. THE
;;; LEFT HALF OF THE SECOND WORD CONTAINS THE ARGS PROPERTY, IN
;;; INTERNAL ARGS PROPERTY FORMAT, AS SPECIFIED IN THE ORIGINAL
;;; LAP CODE BY THE ARGS CONSTRUCT. 
;;;
;;;	TYPE 14	LOC
;;; THE WORD IS A RELOCATABLE QUANTITY SPECIFYING WHERE TO
;;; CONTINUE LOADING.  IT IS NOT PERMITTED TO LOC BELOW THE
;;; ORIGIN OF THE ASSEMBLY. IF THE LOC IS TO A LOCATION HIGHER
;;; THAN ANY YET LOADED INTO, THEN FASLOAD ZEROS OUT ALL WORDS
;;; ABOVE THAT HIGHEST LOCATION UP TO THE LOCATION SPECIFIED. 
;;; FASLOAD KEEPS TRACK OF THE HIGHEST LOCATION EVER LOADED INTO;
;;; THIS VALUE PLUS ONE BECOMES THE VALUE OF BPORG AT THE END OF
;;; ASSEMBLY, REGARDLESS OF THE STATE OF THE LOCATION POINTER
;;; WHEN LOADING TERMINATES.  THIS TYPE IS NEVER USED BY LAP
;;; CODE, BUT ONLY BY MIDAS .FASL CODE. 
;;;
;;;	TYPE 15	PUTDDTSYM
;;; FIRST WORD, THE SYMBOL IN SQUOZE CODE.  IF BIT 4.9=0, THE
;;; SYMBOL IS DEFINED TO DDT IF POSSIBLE WITH THE ADDRESS OF THE
;;; WORD OF BINARY PROGRAM SPACE ABOUT TO BE LOADED INTO AS ITS
;;; VALUE.  IF BIT 4.9=1, THE VALUE IS GOBBLED FROM THE FOLLOWING
;;; WORD. BIT 4.8 (OF THE WORD CONTAINING THE SQUOZE) MEANS
;;; RELOCATE THE LEFT HALF OF THE VALUE BY THE LOAD OFFSET, AND
;;; BIT 4.7 LIKEWISE FOR THE RIGHT HALF.  WHETHER OR NOT THE
;;; SYMBOL ACTUALLY GETS PUT IN DDT'S SYMBOL TABLE IS A FUNCTION
;;; OF THREE CONDITIONS: FIRST, THAT THERE IS A DDT WITH A SYMBOL
;;; TABLE; SECOND, THE VALUE OF THE LISP VARIABLE "SYMBOLS"; 
;;; THIRD, BIT 4.6 OF THE FIRST PUTDDTSYM WORD. THE FIRST
;;; CONDITION OF COURSE MUST BE SATISFIED. IF SO, THEN THE SYMBOL
;;; IS PUT IN THE SYMBOL TABLE ONLY IF SYMBOLS HAS A NON-NIL
;;; VALUE. FURTHERMORE, IF THAT VALUE IS THE ATOM SYMBOLS ITSELF,
;;; THEN THE SYMBOL IS PUT ONLY IF BIT 4.6 IS ON (INDICATING A
;;; "GLOBAL" SYMBOL). 
;;;
;;;	TYPE 16	EVAL MUNGEABLE
;;; A SERIES OF WORDS SIMILAR TO THOSE FOR TYPE 5, BUT WITH NO
;;; FOLLOWING HASH KEY. AN S-EXPRESSION IS CONSTRUCTED AND
;;; EVALUATED. THIS IS USED FOR THE SO-CALLED "MUNGEABLES" IN A
;;; FILE OF LAP CODE.  IF THE LEFT HALF OF THE LAST WORD IS -1,
;;; THE VALUE IS THROWN AWAY. IF IT IS -2, THE VALUE IS ENTERED
;;; IN THE ATOMTABLE. 
;;;
;;;	TYPE 17	END OF BINARY
;;; ONE WORD, WHICH MUST BE "*FASL+" (OR "*FASL*") IN SIXBIT.
;;; THIS SHOULD BE THE LAST DATA WORD IN THE FILE. ANY RELOCATION
;;; BYTES LEFT OVER AFTER A TYPE 17 ARE IGNORED.  THIS SHOULD BE
;;; FOLLOWED EITHER BY END OF FILE OR A WORD FULL OF ↑C'S. 

;;; INTERNAL AUTOLOAD ROUTINE

IFE QIO,[
IALB:	HRRZ C,(A)
	HLRZ A,IRACOM
	HRRZ B,@IUNIT
	PUSHJ P,CONS
	JSP T,SPECBIND
	   0 A,IUNIT
NW%	SAVEFX UFN1 UFN2
	MOVEI A,(C)		;INTERNAL AUTOLOAD BREAK IS ESSENTIALLY FASLOAD
	PUSHJ P,FASLOAD
NW%	RSTRFX UFN2 UFN1
	JRST UNBIND
]		;END OF IFE QIO

IFN QIO,[
IALB:	HRRZ AR2A,VDEFAULTF	;SUBR 1
	JSP T,SPECBIND
	   0 AR2A,VDEFAULTF
	HRRZ A,(A)
IT$	MOVEI B,QCOMDIR
IT%	MOVEI B,QCOMDEV
	PUSHJ P,MERGEF
	PUSHJ P,LOAD
	JRST UNBIND
]		;END OF IFN QIO

FASLOAD:
	JSP TT,FWNACK
	FA01234,,QFASLOAD
	SKIPE FASLP
	 JRST LDALREADY
	PUSH P,FLP		;FOR DEBUGGING PURPOSES
	PUSH P,FXP		.SEE LDEOMM
	PUSH P,SP
10$	SETOM LDEOFP		;FLAG FOR CRUFTY D10 DUMP MODE I/O EOF
IFE QIO,[
	AOJN T,LDXXX7
	HLRZ A,(A)
	MOVEI B,QFASLL
	PUSHJ P,CONS
LDXXX7:	MOVEM A,LDFNAM
]		;END OF IFE QIO
IFN QIO,[
SA$	SETOM  SAFSFG
	PUSHJ P,FIL6BT
SA$	SETZM SAFSFG
	MOVSI T,(SIXBIT \*\)
IT$	MOVE TT,[SIXBIT \FASL\]	;DEFAULT SECOND FILE NAME IS "FASL"
10$	MOVSI TT,(SIXBIT \FAS\)	;DEFAULT FILE NAME EXTENSION IS "FAS"
20$	MOVE TT,[ASCII \FASL\]
20%	CAMN T,(FXP)
20%	 MOVEM TT,(FXP)
20$	SKIPE -L.6VRS-L.6EXT+1(FXP) ;EXTENSION NULL?
20$	 CAMN T,-L.6VRS-L.6EXT+1(FXP) ;OR EQUAL TO *?
20$	  MOVEM TT,-L.6VRS-L.6EXT+1(FXP) ;EITHER, USE FASL
	PUSHJ P,DMRGF
	PUSHJ P,6BTNML
]		;END OF IFN QIO
	MOVEI B,TRUTH
	JSP T,SPECBIND
Q$	   0 A,LDFNAM		;QIO MUST BIND LDFNAM FOR POSSIBLE RECURSIVE FASLOAD
	   0 B,VNORET
Q%	   0 B,FASLP
Q$	       FASLP
IFE QIO,[
	PUSH P,IUNIT
	MOVEI T,6		;OPEN FASL FILE IN BLOCK IMAGE MODE
	PUSHJ P,UINITA
10%	.OPEN DSIC,UTIN
10%	JRST LDOERR
IFN D10,[
	MOVEI T,16
	SETZ T+2,
	PUSHJ P,LDOPN1		;USE COMMON OPEN
	JRST LDOERR		;USE LOAD ERROR MESSAGE
	LOOKUP DSIC,T
	JRST LDOERR		;SAME MESSAGE
	SETZM D10PTR
]		;END OF IFN D10
	SUB P,R70+1		;SUB OFF OLD IUNIT
	UNLOCKI
	PUSHJ P,LDFNSET
	MOVEM A,LDFNAM
]		;END OF IFE QIO
IFN QIO,[
	PUSH P,[LDXXY1]
	PUSH P,A
	PUSH P,[QFIXNUM]
	MOVNI T,2
	JRST $OPEN
LDXXY1:	MOVEM A,FASLP
	PUSH P,A
	HRRZM A,LDBSAR
	MOVE A,LDFNAM
	PUSHJ P,DEFAULTF
	SETZM LDTEMP		;CROCK!
]		;END OF IFN QIO

;FALLS THROUGH

;FALLS IN

;;; COME HERE TO "DO IT SOME MORE"

LDDISM:	PUSHJ P,LDGDDT		;SET UP DDT FLAG:  0 => NO DDT; 
	PUSH P,TT		;-1,,0 => DDT, NO SYMBOLS; 1,,X => DDT, SYMBOLS
				;X MAY BE 0, OR SAR FOR SYMBOL TABLE ARRAY
				; (SEE LDPUT)
	SKIPN F,VPURE		;SET UP CALL PURIFY FLAGS:
				;400000,,XXX => NO PURIFY HACKERY
	 TLOA F,400000		;200000,,XXX => SUBST XCTS FOR CALLS,
				; PUT CALLS IN SEPARATE PAGES
				;100000 BIT MEANS FASLOAD INTO HISEG (D10 ONLY)
	  HRRZ F,VPURCLOBRL	;0,,<PURE LIST> => SUBST PUSHJS AND
				; JRSTS FOR CALLS
	PUSH P,F		;	ANY CALLS NOT IMMEDIATELY SMASHABLE
	MOVE A,VPURE		;	ARE CONSED ONTO THE PURE LIST
	PUSHJ P,FIXP		;LEAVES VALUE IN TT IF INDEED FIXNUM
	JUMPE A,LDXXX1
	MOVSI F,200000
	IORM F,(P)
IFN D10,[
	JUMPGE TT,LDXQQ7	;IF PURE IS A NEGATIVE FIXNUM, DO HISEG HACKERY
SA%	HRROI T,.GTSGN		;FIND WHETHER HISEG SHARABLE (FROM
SA%	GETTAB T,		;6.03 MONITOR CALLS)
SA%	 .VALUE
SA%	TLNN T,(SN%SHR)
SA$	SKIPL .JBHRL		;IS HISEG CURRENTLY WRITE-PROTECTED?
	 JRST LDXQQ5
	PUSH FXP,TT
	LOCKI			;LOCK OUT INTS AROUND USE OF TMPC
	SKIPN SGANAM
	 JRST FASLUH
	MOVEI T,.IODMP
	MOVE TT,SGADEV
	SETZ D,
	OPEN TMPC,T		;OPEN UP .SHR FILE DEVICE IN DUMP MODE
	 JRST FASLUH
	MOVE T,SGANAM
	MOVE TT,SGAEXT
	SETZ D,
	MOVE R,SGAPPN
	LOOKUP TMPC,T
	 JRST FASLUR
SA$	MOVS T,R
SA%	JUMPGE R,FASLUR
SA%	HLRE T,R
	MOVNS T			;T GETS LENGTH OF .SHR FILE
	PUSHJ P,LDRIHS		;GO READ IN HIGH SEGMENT (FROM WITHIN LOSEG!)

LDRTHS:	RELEASE TMPC,		;FLUSH TEMP CHANNEL
	UNLOCKI
	POP FXP,TT
	MOVE F,SVPRLK		;CAN NOW USE SAVED PURE SEGMENTS FROM LAST TIME
	SETZM SVPRLK
	MOVEM F,PRSGLK
LDXQQ5:	MOVSI F,100000
	IORM F,(P)		;SET FLAG SAYING WE'RE HACKING THE HISEG
	MOVMS TT
	PUSHJ P,LDXHHK		;SET UP XCT PAGES USING HISEG 
	MOVE A,V.PURE
	PUSHJ P,FIXP		;LEAVES VALUE IN TT IN INDEED FIXNUM
	JUMPE A,LDXXX1		;IF FIXNUM, IT IS AN ESTIMATE OF PURE FREE STG
	CAIG TT,10		;IF 10 OR LESS, MULTIPLY BY 1024.
	 LSH TT,12
	CAILE TT,0		;CHECK FOR REASONABLENESS
	 CAILE TT,MEMORY+.RL1-ENDHI
	  JRST LDYERR
	MOVSI D,-NFF-1
	SUB TT,PFSSIZ(D)	;SUBTRACT FROM ESTIMATE THE CURRENT
	AOBJN D,.-1		; SIZES OF EXISTING PURE AREAS
	MOVE D,PRSGLK
LDXQQ2:	JUMPE D,LDXQQ3		;ALSO ACCOUNT FOR ANY PURE SEGMENTS
	SUBI TT,SEGSIZ		; ALREADY IN THE FREELIST
	LDB D,[SEGBYT,,GCST(D)]
	JRST LDXQQ2

LDXQQ3:	JUMPLE TT,LDXXX1	;JUMP IF GUESSTIMATE ALREADY SATISFIED
	ADDI TT,SEGSIZ-1	;ROUND UP TO AN INTEGRAL
	ANDI TT,SEGMSK		; NUMBER OF SEGMENTS
	MOVE D,HBPORG
	ADDI D,SEGSIZ-1		;ALSO ROUND UP HISEG BPORG
	ANDI D,SEGMSK
	MOVE R,D
	ADD D,TT
	SUBI D,1
	TLNE D,-1		;COMPLAIN IF NOT ENOUGH MEMORY
	 JRST FASLNX
	MOVEM D,HBPORG		;UPDATE HISEG BPORG PAST ALLOCATED SEGMENTS
	AOS HBPORG
	CAMG D,HBPEND
	 JRST LDXQQ6
	MOVEM D,HBPEND		;IF NEW HISEG BPORG TOO LARGE,
SA%	HRLZI D,(D)
SA%	CORE D,
SA$	CORE2 D,		; MUST REQUEST MORE CORE FOR HISEG
	 HALT
LDXQQ6:	LSH R,-SEGLOG		;UPDATE SEGMENT TABLES,
	LSH TT,-SEGLOG		; AND ADD PURE SEGMENTS TO FREELIST
	MOVE D,[$XM+PUR,,QRANDOM]
	MOVE F,PRSGLK
LDXQQ8:	MOVEM D,ST(R)
	SETZM GCST(R)
	DPB F,[SEGBYT,,GCST(R)]
	MOVEI F,(R)
	ADDI R,1
	SOJG TT,LDXQQ8
	MOVEM F,PRSGLK
	JRST LDXXX1

LDXQQ7:	PUSHJ P,LDXHAK		;SET UP XCT HACK PAGES WITHOUT HISEG
]		;END OF IFN D10

;FALLS THROUGH

;FALLS IN

LDXXX1:
IFE QIO,[
	HRRZ B,FASLP		;FASLP IS T FIRST TIME, ELSE
	CAIE B,TRUTH		; SAR OF I/O BUFFER ARRAY
	 JRST LDXXX8
	SETZM LDTEMP
	MOVEI TT,LLDBF		;CREATE I/O BUFFER ARRAY
	MOVSI A,400000
	PUSHJ P,MKFXAR
	HRRZM B,LDBSAR		;SAVE ADDRESS OF SAR
	MOVEM B,FASLP
LDXXX8:	PUSH P,B		;SAVE SAR FOR I/O BUFFER [FROM GC]
]		;END OF IFE QIO
	MOVE TT,[-LLDAT+1,,1]	;INIT ATOMTABLE AOBJN INDEX
	MOVEM TT,LDAAOB
	MOVEI TT,LLDAT		;CREATE ATOMTABLE ARRAY
	MOVSI A,400000
	PUSHJ P,MKLSAR
	PUSH P,A		;SAVE SAR OF ATOM-TABLE ARRAY FOR GC PROTECTION
	HRRZM B,LDASAR		;SAVE ADDRESS OF SAR
	PUSHJ P,LDLRSP		;LOCKI, AND SET UP ARRAY POINTERS
	SETZ TT,		;ENTRY 0 IN ATOMTABLE IS FOR NIL
	SETZM @LDAPTR
	MOVEI TT,LDFERR		;INIT ADDRESS FOR PREMATURE EOF
	MOVEM TT,LDEOFJ
	SKIPE F,LDTEMP		;IF LDTEMP IS NON-NIL, IT IS THE SAVED I/O BUFFER POINTER
	 JRST LDXXX9
	JSP T,LDGTW1		;GET FIRST WORD OF FILE
	TRZ TT,1		;COMPATIBILITY CROCK
	CAME TT,[SIXBIT \*FASL*\]	;IT BETTER BE THIS VALUE!
	 JSP D,LDFERR
LDXXX9:	JSP T,LDGTWD		;GET VERSION OF LISP FILE WAS ASSEMBLED IN
	XOR TT,LDFNM2
	MOVEM TT,LDF2DP		;NON-ZERO IFF VERSIONS DIFFERENT
	MOVE AR1,[000400,,LDBYTS]	;INIT RELOCATION BYTES POINTER
	SETZM LDHLOC
	HRRZ R,@VBPORG
10$	MOVE TT,LDPRLS(P)
10$	TLNE TT,100000		;SKIP UNLESS LOADING INTO HISEG
10$	 HRRZ R,HBPORG
	HRRM R,LDOFST		;INITIALIZE LOAD OFFSET
	JRST LDABS0		;R HAS ADDRESS TO LOAD NEXT WORD INTO

SUBTTL	ROUTINE TO SET UP PAGES FOR XCT HACK (D10, FIXED NUMBER OF SLOTS)
IFN D10,[
;;;	TT HAS NUMBER OF WORDS (1K BLOCKS IF <8) DESIRED.

LDXHHK:	HRROS (P)		;THIS ENTRY USES THE HISEG
LDXHAK:	SKIPE LDXSIZ		;MAYBE WE NEED TO SET UP PAGES FOR XCT HACKERY
	 POPJ P,		;IF NOT, JUST EXIT
	JUMPLE TT,LDXERR
	CAIG TT,10		;IF 10 OR LESS, MULTIPLY BY 1024.
	 LSH TT,12
	ADDI TT,PAGSIZ-1	;ROUND UP TO A WHOLE NUMBER OF PAGES
	ANDI TT,PAGMSK
	TLNE TT,-1
	 JRST LDXERR
	PUSH FXP,TT
	MOVE D,(FXP)		;GET ESTIMATED NUMBER OF LINKS
	MOVEM D,LDXSIZ		;SAVE AS SIZE OF XCT AREA
	MOVEM D,LDXSM1		;ALSO NEED THAT VALUE MINUS 1
	SOS LDXSM1
	MOVE TT,@VBPORG		;CREATE TWO AREAS IN BPS THAT BIG:
	HRRZ T,TT		; THE FIRST FOR THE XCTS TO POINT TO,
	ADD TT,D		; THE SECOND TO RESTORE THE FIRST FROM
	HRL T,TT
	MOVE R,(P)
	TLNE R,1
	 HRL T,HBPORG
	MOVEM T,LDXBLT		;SAVE BLT POINTER FOR RESTORING
	TLNN R,1		;USING HISEG, DON'T TAKE SECOND AREA FROM LOSEG
	 ADD TT,D		;ADD IN FOR SECOND AREA
	JSP T,FXCONS		;NEW VALUE FOR BPORG
	PUSH P,A
	TLNN R,1
	 LSH D,1
	MOVE TT,D
	PUSHJ P,LGTSPC		;NOW TRY TO GET REQUIRED CORE
	JUMPE TT,FASLNX
	MOVE R,-1(P)
	TLNN R,1
	 JRST LDXHK3
	MOVE D,(FXP)		;GOBBLE SECOND AREA OUT OF HISEG
	ADD D,HBPORG
	TLNN D,-1
	 JRST LDXHK2
LDXHK1:	SETZM LDXSIZ		;HAVEN'T REALLY WON AFTER ALL
	JRST FASLNX

LDXHK2:	MOVEM D,HBPORG
	SUBI D,1
	CAMG D,HBPEND		;MAY NEED TO EXTEND HISEG
	 JRST LDXHK3
	MOVEM D,HBPEND
SA%	HRLZI D,(D)
SA%	CORE D,
SA$	CORE2 D,
	 JRST LDXHK1
LDXHK3:	POP P,VBPORG		;GIVE BPORG NEW VALUE
	MOVE T,LDXBLT		;ZERO OUT BOTH AREAS
	MOVE TT,@VBPORG
	HRL T,T
	SETZM (T)
	ADDI T,1
	BLT T,-1(TT)
	TLNN R,1
	 JRST LDXHK5
	MOVS T,LDXBLT		;WHEN USING HISEG, NEED AN EXTRA
	MOVE TT,HBPORG		; BLT TO ZERO OUT SECOND AREA
	BLT T,-1(TT)
LDXHK5:	HRRZ T,LDXBLT		;SET UP LDXDIF WITH THE DIFFERENCE
	HLRZ TT,LDXBLT		; BETWEEN THE ORIGINS OF AREA 1 AND
	SUB T,TT	.SEE LDPRC6
	HRRM T,LDXDIF		; AREA 2 TO MAKE INSTALLING ENTRIES EASIER
	POPI FXP,1
	JRST TRUE
]		;END IFN D10

SUBTTL ITS AND TOPS-20, VARIABLE NUMBER OF XCT PAGES, DYNAMICALLY ALLOCATED
IFN ITS+D20,[
LDXHAK:	PUSH FXP,AR1		;AR1 MUST BE PRESERVED, AT ALL COSTS!
	LOCKI			;INTERRUPTS MUST BE OFF OVER CALL TO GRBSEG
	PUSHJ P,GRBSEG		;GET ONE SEGMENT OF TYPE RANDOM
	 JRST LDXIRL		;RELEASE INTERRUPTS AND GIVE NON-SKIP RETURN
	UNLOCKI
	PUSHJ P,GRBPSG		;GET ONE PURE SEGMENT INTO AC T
	POP FXP,AR1
	LSH T,SEGLOG		;MAKE PURE SEGMENT INTO ADDRESS
	HRRZM T,LDXPSP(TT)	;REMEMBER PURE SEGMENT ADDRESS
	HRLI T,(T)		;BUILD A BLT POINTER TO ZERO PURE PAGE
	HRRZI D,SEGSIZ-1(T)	;LAST LOC TO ZERO
	SETZM (T)		;ZERO FIRST LOC
	ADDI T,1
	BLT T,(D)		;AND ALL THE REST
	HRLZI T,LDXOFS(TT)	;BUILD BLT POINTER TO CLEAR NEW IMPURE SEG
	HRRI T,LDXOFS+1(TT)
	SETZM LDXOFS(TT)
	BLT T,SEGSIZ-1(TT)	;CLEAR THE WHOLE SEGMENT
	MOVNI T,LDHSH1+1	;NUMBER OF ENTRIES IN TABLE
	IMULI T,LDX%FU		;MAKE INTO NEGATIVE PERCENTAGE
	PUSH FXP,TT
	IDIVI T,100.
	POP FXP,TT
	MOVEM T,LDXLPC		;AND THE COUNT
	MOVE T,LDXLPL		;REMEMBER LOC OF LAST PAGE USED
	MOVEM TT,LDXLPL		;SAVE THIS PAGE LOCATION
	JUMPE T,LDXFLC		;STORE IN POINTER LOC IF NO PREVIOUS SEGMENTS
	HRLM TT,(T)		;LINK INTO LIST
	AOS (P)
	POPJ P,
LDXFLC:	MOVEM TT,LDXPNT
	AOS (P)
	POPJ P,
LDXIRL:	UNLOCKI
	POP FXP,AR1
	POPJ P,
]	;END IFN ITS+D20

SUBTTL	MAIN FASLOAD LOOP

;;; FROM THIS POINT ON, UNTIL A FATAL ERROR OCCURS OR LOCATION LDFEND IS REACHED,
;;; THESE ACCUMULATORS ARE DEDICATED TO THE FOLLOWING PURPOSES:
;;;	AR1	BYTE POINTER FOR GETTING SUCCESSIVE RELOCATION TYPES
;;;	R	AOBJN POINTER FOR PUTTING WORDS INTO BINARY PROGRAM SPACE
;;;	F	AOBJN INDEX FOR ACCESSING WORDS FROM INPUT BUFFER ARRAY

LDREL:	HRRI TT,@LDOFST		;[RELOCATABLE WORD]
LDABS:	MOVEM TT,(R)		;[ABSOLUTE WORD]
LDABS1:	AOBJN R,LDBIN		;JUMP IF ROOM LEFT OF WHAT WE GRABBED
LDABS0:
10$	MOVE TT,LDPRLS(P)	;FOR D10, MUST PASS LDPRLS IN TT TO LDGTSP
	PUSHJ P,LDGTSP
	PUSHJ P,LDRSPT
LDBIN:	SKIPE INTFLG		;[LOAD BINARY WORD (OR SOME OTHER MESS)]
	 PUSHJ P,LDTRYI		;GIVE A POOR INTERRUPT A CHANCE IN LIFE
	TLNN AR1,770000
	 JRST LDBIN2		;OUT OF RELOCATION BYTES - MUST GET MORE
LDBIN1:	JSP T,LDGTWD		;GET WORD FROM INPUT FILE
	ILDB T,AR1		;GET CORRESPONDING RELOCATION BYTE
	JSP D,@LDTTBL(T)	; - IT TELLS US WHERE TO GO

LDBIN2:	JSP T,LDGTWD		;GET WORD OF RELOCATION BYTES
	MOVEM TT,LDBYTS
	SOJA AR1,LDBIN1		;INIT BYTE POINTER AND GO GET DATA WORD

LDTTBL:	LDABS		;  0  ABSOLUTE
	LDREL		;  1  RELOCATABLE
	LDSPC		;  2  SPECIAL
	LDPRC		;  3  PURIFIABLE CALL
	LDQAT		;  4  QUOTED ATOM
	LDQLS		;  5  QUOTED LIST
	LDGLB		;  6  GLOBALSYM PATCH
	LDGET		;  7  GET DDT SYMBOL PATCH
	LDAREF		; 10  ARRAY REFERENCE
	LDFERR		; 11  UNUSED
	LDATM		; 12  ATOMTABLE ENTRY
	LDENT		; 13  ENTRY POINT INFO
	LDLOC		; 14  LOC TO ANOTHER PLACE
	LDPUT		; 15  PUT DDT SYMBOL
	LDEVAL		; 16  EVALUATE MUNGEABLE
	LDBEND		; 17  END OF BINARY

;;; LOADER GET SPACE ROUTINE.  PUTS SOME DISTANCE BETWEEN BPORG AND BPEND.
;;; R MUST BE SET UP ALREADY.  FOR D10, TT MUST HAVE LDPRLS.
;;; THE LEFT HALF OF R IS ADJECTED TO REFLECT THE SPACE OBTAINED.

LDGTSP:
10$	TLNE TT,100000		;CHECK IF LOADING INTO HISEG
10$	 JRST LDGSP3		;IF SO, EXPAND THAT
	MOVE TT,@VBPEND		;SEE IF ENOUGH ROOM LEFT TO GRAB MORE
	SUB TT,@VBPORG
	SUBI TT,100		;RANDOMLY CHOSEN QUANTITY
	JUMPGE TT,LDGSP1	;YES - GO GRAB IT
	SAVEFX AR1 D R F
	MOVEI TT,4*PAGSIZ	;GET MANY BLOCKS OF BPS
LDGS0A:	MOVEM TT,GAMNT
	PUSHJ P,GTSPC1
	JUMPN TT,LDGS0H
	MOVE TT,GAMNT
	CAIG TT,100
	 JRST FASLNC
	MOVEI TT,100
	JRST LDGS0A

LDGS0H:	RSTRFX F R D AR1
LDGSP1:	MOVEI TT,(R)
	ADDI TT,PAGSIZ		;TRY TO GOBBLE <PAGSIZ>
	CAMLE TT,@VBPEND	; WORDS, BUT IN ANY CASE
	 MOVE TT,@VBPEND	; NO MORE THAN BEYOND BPEND
	JSP T,FIX1A
	MOVEM A,VBPORG
	MOVEI TT,(R)
	SUB TT,@VBPORG
	HRLI R,(TT)		;INIT AOBJN POINTER IN R
	POPJ P,

IFN D10,[
LDGSP3:	MOVE TT,HBPEND
	SUBI TT,(R)		;DO NOT MERGE THIS WITH FOLLOWING SUBI! MAYBE R>777700
	SUBI TT,100		;RANDOMLY CHOSEN QUANTITY
	JUMPGE TT,LDGSP6
	MOVE TT,HBPEND
	ADDI TT,4*PAGSIZ
	TLNE TT,-1
	 MOVSI TT,(MEMORY)
	ADDI TT,PAGSIZ-1
	ANDCMI TT,#PAGMSK	;*NOT* SAME AS  ANDI TT,PAGMSK  !!!
	MOVE T,TT
	SUBI T,1
	CAMG T,HBPEND
	 JRST LDGSP4
SA%	HRLZI T,(T)
SA%	CORE T,
SA$	CORE2 T,
	 JRST FASLNC
	MOVE AR2A,[$XM+PUR,,QRANDOM]
	AOS B,HBPEND
	MOVEI C,(B)
	SUBI C,(TT)
	LSHC B,-SEGLOG
	HRLI B,(C)
LDGSP5:	MOVEM AR2A,ST(B)
	SETZM GCST(B)
	AOBJN B,LDGSP5
LDGSP4:	MOVEM TT,HBPEND
	SOS HBPEND
LDGSP6:	MOVE TT,HBPEND
	MOVEM TT,HBPORG
	SUBM R,TT
	HRLI R,(TT)
	POPJ P,
]		;END OF IFN D10

SUBTTL	SPECIAL VALUE CELL AND QUOTED ATOM REFERENCES

LDSPC:	MOVE T,TT		;[SPECIAL]
	HLR TT,@LDAPTR		;GET ADDRESS OF SPECIAL CELL
	TRNE TT,777000		;WAS SUCH AN ADDRESS REALLY THERE?
	 JRST LDABS		;YES, WIN
	TRNE TT,6		;NO, IS THIS ATOM A NUMBER
	 JSP D,LDFERR		;YES - LOSE!!!
	HRRZ TT,T		;IS THERE AN ATOM THERE AT ALL
	HRRZ A,@LDAPTR
	SKIPN D,A
	 JSP D,LDFERR		;NO, LOSE
	HLRZ B,(A)
	HRRZ A,(B)
	CAIE A,SUNBOUND
	 JRST LDSPC1
	PUSH P,D		;NONE THERE - MUST MAKE ONE
	MOVEI B,QUNBOUND
	JSP TT,MAKVC		;RETURN SY2 POINTER IN B
LDSPC1:	HLRZ TT,(B)		;GET SYMBOL FLAG BITS
	TRO TT,SY.CCN\SY.OTC	;NEEDED-BY-COMPILED-CODE, OTHER THAN CALL
	TRNN TT,SY.PUR		;WAS VALUE CELL PURE?
	 HRLM TT,(B)		;NO, THEN MUST PROTECT VALUE CELL
	MOVE TT,T		;SAVE ADDRESS OF VALUE CELL
	HRLM A,@LDAPTR		; IN ATOMTABLE
	HRR TT,A		;AT LAST WE WIN
	JRST LDABS

LDQAT:	MOVE D,@LDAPTR		;[QUOTED ATOM]
	TLNN D,777001		;SKIP IF SPECIAL OR ALREADY USED
	 TLO D,1		;ELSE TURN ON REFERENCE BIT
	MOVEM D,@LDAPTR
	HRRI TT,(D)
	TRNN D,-1
	 JRST LDABS		;DON'T HACK ANYTHING FOR NIL
	TLNE D,777006		;IF NUMBER OR ALREADY HACKED SYM BLK, SKIP IT
	 JRST LDABS
	HLRZ T,(D)
	HLL T,(T)		;FETCH SYMBOL BITS
	TLO T,SY.CCN\SY.OTC	;FLAG SYMBOL AS NEEDED FOR OTHER THAN CALL
	TLNN T,SY.PUR		;DON'T TRY TO WRITE IF PURE
	 HLLM T,(T)
	JRST LDABS


SUBTTL	QUOTED LIST REFERENCES

LDQLS:	MOVSI D,11		;[QUOTED LIST]
	SKIPL LDPRLS(P)		;CAN'T COUNT ON ANYTHING IN PURE
	 MOVSI D,1		; FREE STORAGE PROTECTING ANYTHING
	PUSHJ P,LDLIST		;GOBBLE UP A LIST
	MOVEM TT,(R)		;PUT WORD IN BPS
	JSP T,LDGTWD		;GET HASH KEY FOR LIST
	TLZ A,-1
	SKIPE VGCPRO
	 JRST LDQLS4
	PUSH FXP,D
	PUSH FXP,AR1
	TLZ A,-1
	SKIPE D,TT
	 JRST LDQLS3
	PUSH P,A
	PUSHJ P,SXHSH0
	POP P,A
LDQLS3:	SKIPN V.PURE		;SKIP FOR PURE HACKERY
	 JRST LDQLS1
	PUSH FXP,D		;SAVE HASH KEY
	PUSH P,A		;SAVE LIST
	MOVNI T,1		;THIS MEANS JUST LOOKUP
	PUSHJ P,LDGPRO
	POP P,B
	POP FXP,D
	JUMPN A,LDQLS2		;ON GCPRO LIST, SO USE IT
	MOVE A,B
	PUSHJ P,PURCOPY		;NOT ON GCPRO LIST, SO PURCOPY IT
LDQLS1:	MOVEI T,1		;THIS MEANS PROTECT OR HAND BACK COPY
	PUSHJ P,LDGPRO		;PROTECT LIST FROM FEROCIOUS GC!
LDQLS2:	POP FXP,AR1
	POP FXP,D
LDQLS5:	JUMPE D,LDEVL7		;MAYBE THIS LIST GOES INTO ATOMTABLE
	HRRM A,(R)		;SAVE ADDRESS OF LIST (WHICH MAY
	JRST LDABS1		; BE DIFFERENT NOW) BACK INTO WORD

LDQLS4:	JSP T,LDQLPRO
	JRST LDQLS5

LDQLPRO:
	HRRZ B,LDEVPRO		;GC-PROTECT HAPPENS BY PUSHING ONTO A LIST
	PUSHJ P,CONS
	MOVEM A,LDEVPRO
	JRST %CAR

LDGPRO:	SKIPE GCPSAR		;PROTECT SOMETHING ON THE GCPSAR
	 JRST .GCPRO
	PUSHJ P,.GCPRO		;THE LOOKUP CAUSES THE CREATION OF A NEW ARRAY
	JRST LDRSPT		;SO WE HAVE TO RESTORE PTRS AFTERWARDS


SUBTTL	PURIFIABLE CALL

LDPRC:	MOVE D,@LDAPTR		;[PURIFIABLE CALL]
	TRNN D,-1		;MUST HAVE NON-NIL ATOM TO CALL
	 JSP D,LDFERR
	TLNE D,777000
	 JRST LDPRC1		;JUMP IF ATOM HAS SPECIAL CELL
	TLNE D,6
	 JSP D,LDFERR		;LOSE IF NUMBER
	TLO D,1			;ELSE TURN ON REFERENCE BIT
	MOVEM D,@LDAPTR
	HLRZ T,(D)		;FETCH SY2 DATA
	HLL T,(T)
	TLO T,SY.CCN		;ONLY CCN, NOT OTC!!
	TLNN T,SY.PUR		;ONLY IF IMPURE
	 HLLM T,(T)
LDPRC1:	HRR TT,D		;PUT ADDRESS OF ATOM IN CALL
	SKIPGE T,LDPRLS(P)	;SKIP FOR PURIFYING HACKERY
	 JRST LDABS		;OTHERWISE WE'RE DONE
	TLNN T,200000		;SKIP FOR XCT STUFF
	 SETZ T,		;ELSE DO ORDINARY SMASH
	PUSHJ P,PRCHAK		;*** SMASH! ***
	 JRST LDABS1
	MOVEI A,(R)		;NOT SMASHED - CONS ONTO PURE LIST
	MOVE B,LDPRLS(P)
	PUSHJ P,CONS
	MOVEM A,LDPRLS(P)
	JRST LDABS1

;;; ROUTINE TO CLOBBER A CALL INTO BPS, POSSIBLY DOING XCT HACK.
;;;	SKIPS ON *** FAILURE *** TO CLOBBER.
;;;	T NON-ZERO => TRY XCT HACK; OTHERWISE ORDINARY SMASH.
;;;	TT HAS UUO INSTRUCTION TO HACK.
;;;	R HAS ADDRESS TO PUT UUO INTO.
;;;	MUST PRESERVE AR1, R, F.
IFN D10,[
;VERSION FOR D10 ONLY, NEWER VERSION SUPPORTS EXTENDABLE NUMBER OF SEGMENTS
PRCHAK:	JUMPE T,LDPRC5		;T ZERO => ORDINARY SMASH
	MOVE T,TT		;SAVE CALL IN T
	IDIV TT,LDXSM1		;COMPUTE HASH CODE FOR CALL
	MOVNM D,LDTEMP		;SAVE NEGATIVE THEREOF
	HLRZ TT,LDXBLT
	ADD D,TT		;ADDRESS TO BEGIN SEARCH
	CAMN T,(D)		;WE MAY WIN IMMEDIATELY
	 JRST LDPRC7
	SKIPN (D)
	 JRST LDPRC6
	ADD TT,LDXSM1		;ELSE MAKE UP AN AOBJN POINTER
	SUBI TT,-1(D)		; AND SEARCH FOR MATCHING CALL
	MOVNI TT,(TT)
	HRL D,TT
LDPRC2:	CAMN T,(D)
	 JRST LDPRC7		;FOUND MATCHING CALL
	SKIPN (D)
	 JRST LDPRC6		;FOUND EMPTY SLOT
	AOBJN D,LDPRC2
	HRLZ D,LDTEMP		;WRAPPED OFF THE END OF THE XCT AREA
	HLR D,LDXBLT		; - MAKE UP NEW AOBJN POINTER
LDPRC3:	CAMN T,(D)		;SECOND COPY OF THE LOOP
	 JRST LDPRC7		;FOUND MATCHING CALL
	SKIPN (D)
	 JRST LDPRC6		;FOUND EMPTY SLOT
	AOBJN D,LDPRC3
LDPRC4:	MOVE TT,T		;TOTAL LOSS - MUST DO SMASH
LDPRC5:	HRRZ AR2A,R		;PUT ADDRESS OF CALL IN AR2A
	MOVEM TT,(AR2A)		;PUT CALL IN THAT PLACE
	JRST LDSMSH		;NOW TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE

LDPRC6:	SKIPG LDXSIZ		;FOUND EMPTY SLOT
	 JRST LDPRC4		;CAN'T USE IT IF PAGES PURIFIED
	MOVEM T,(D)		;SAVE CALL INTO XCT AREA 2
	MOVEM T,@LDXDIF		;ALSO SAVE INTO AREA 1
LDPRC7:	ADD D,LDXDIF		;MAKE UP AN XCT TO POINT TO
	HRLI D,(XCT)		; CALL IN AREA 1
	MOVEM D,(R)
	POPJ P,
]		;END IFN D10

IFN ITS+D20,[
;NEW STYLE SEARCH FOR PROPER LINK LOCATION; ADDS A NEW UUOLINKS SEGMENT IF
; OUT OF SPACE OR IF PARTIALLY EMPTY UUOLINK SEGMENT HAS BEEN PURIFIED
PRCHAK:	JUMPN T,PRCHA1		;DON'T SMASH IMMEDIATLY IF T NON-ZERO
PRCSMS:	HRRZ AR2A,R		;PUT ADDRESS OF CALL IN AR2A
	MOVEM TT,(AR2A)		;PUT CALL IN THAT PLACE
	JRST LDSMSH		;TRY TO SMASH IT, EXITING WITH SKIP ON FAILURE
PRCHA1:	PUSH FXP,R		;NEED D/R PAIR OF ACS
	MOVE D,TT		;GET COPY OF THE CALL
	IDIVI D,LDHSH1		;COMPUTE FIRST HASH VALUE
	MOVEM R,LDXHS1
	MOVE D,TT		;THEN THE SECOND HASH VALUE
	IDIVI D,LDHSH2
	AOS R			;IT BEING ZERO COULD BE A DISASTER
	MOVEM R,LDXHS2
	SKIPN T,LDXPNT		;GET POINTER
	 JRST PRCH2A		;FIRST TIME THROUGH ALWAYS ADD NEW SEGMENT
PRCH1A:	HRRZ D,LDXPSP(T)	;GET POINTER TO PURE PAGE
	MOVEI R,LDXOFS(D)	;POINTER TO FIRST WORD OF DATA
	ADDI D,SEGSIZ-1		;THIS IS THE LAST WORD IN THE SEGMENT
	ADD R,LDXHS1		;START FROM THE FIRST HASH VALUE
PRCH1B:	CAMN TT,(R)		;MATCH?
	 JRST PRCHA3		;YUP, SO USE THIS SLOT
	SKIPN (R)		;END OF CHAIN?
	 JRST PRCHA4		;YES, ON TO NEXT SEGMENT
	ADD R,LDXHS2		;STEP BY HASH VALUE
	CAILE R,(D)		;MUST NOT RUN OFF END OF SEGMENT
	 SUBI R,LDHSH1		;SO TAKE IT MOD LDHSH1
	JRST PRCH1B		;AND TRY THIS SLOT
PRCHA4:	HLRZ D,LDXPSP(T)	;GET POINTER TO NEXT SEGMENT
	JUMPE D,PRCHA2
	MOVEI T,(D)
	JRST PRCH1A
PRCHA3:	HRRZ D,LDXPSP(T)	;SUBTRACTING THIS WILL GIVE ABSOLUTE SEG OFFSET
	SUBM R,D
	ADDI D,(T)		;THEN PRODUCE POINTER TO FROB TO XCT
	POP FXP,R		;RESTORE POINTER TO CODE
	HRLI D,(XCT)
	MOVEM D,(R)		;THEN STORE THE NEW INSTRUCTION
	POPJ P,

;GET HERE WITH C(R) POINTING TO SLOT TO ADD NEW ENTRY TO IN PURE TABLE, DUE TO
; THE DESIGN OF THE MECHANISM, IN THE CASES THAT R IS INVALID, A NEW UUO PAGE
; WILL HAVE TO BE ADDED AND R WILL NOT BE USED.  IF THAT IS CHANGED, THIS
; ROUTINE MUST BE FIXED
PRCHA2:	AOSLE LDXLPC		;IF THIS SEGMENT IS FULL
	 JRST PRCH2A		; ADD A NEW ONE
	MOVEM TT,(R)		;STORE THE CALL IN THE POTENTIALLY PURE SEGMENT
	HRRZ D,LDXPSP(T)	;THEN BUILD POINTER TO IMPURE SEGMENT
	SUBM R,D
	ADDI D,(T)		;D CONTAINS ADR IN IMPURE SEGMENT
	MOVEM TT,(D)		;STORE THE CALL INSTRUCTION THERE
	POP FXP,R		;GET ADR OF ACTUAL CODE
	HRLI D,(XCT)		;THEN INSTRUCTION TO PLANT THERE
	MOVEM D,(R)
	POPJ P,
PRCH2A:	PUSH FXP,TT		;SAVE TT OVER SEGMENT GRAB
	PUSHJ P,LDXHAK		;ADD A NEW SEGMENT
	 LERR [SIXBIT \CANNOT ADD NEW UUOLINKS SEGMENT - FASLOAD!\]
	POP FXP,TT
	MOVE T,LDXLPL		;GET POINTER TO THE PAGE JUST ADDED
	MOVEI D,LDXOFS(T)	;FIRST DATA ADR
	ADD D,LDXHS1		;ADR TO INSTALL CALL INTO
	MOVEM TT,(D)		;STORE THE CALL TO BE POTENTIALLY SMASHED
	HRLI D,(XCT)		;THE XCT INSTRUCTION
	POP FXP,R
	MOVEM D,(R)		;PLANT IN CODE
	HRRZ D,LDXPSP(T)	;PURE SEGMENT POINTER
	ADD D,LDXHS1
	ADDI D,LDXOFS
	MOVEM TT,(D)		;PLANT CALL IN POTENTIALLY PURE SEGMENT
	POPJ P,

;HERE TO TRY TO SMASH CALL IN IMPURE SEGMENT.  CALLED ONLY IF FLAG IS SET.
; POINTER TO WORD IN THE SEGMENT IS IN D.  DESTROYS A, B, C, T
PRTRTS:	HRRZ AR2A,D		;PUT ADDRESS OF CALL IN AR2A
	PUSH FXP,D		;SAVE VALUABLE AC'S
	PUSH FXP,TT
	PUSH FXP,T
	PUSHJ P,LDSMSH		;TRY TO SMASH THE CALL
	 JFCL			;WE DON'T REALLY CARE IF IT WINS OR NOT
	POP FXP,T
	POP FXP,TT
	POP FXP,D
	POPJ P,
]		;END IFN ITS+D10

;;; SMASH A CALL-TYPE UUO IN MEMORY TO BE A PUSHJ OR JRST OR WHATEVER.
;;; AR2A HAS THE LOCATION OF THE CALL.
;;; RETURN SKIPS IF IT CAN'T BE SMASHED.
;;; DESTROYS A, B, C, T, TT, D; SAVES AR1, AR2A, R, F.
;;; MUST NOT USER ANY PDL EXCEPT THE REGPDL (P).
.SEE PURIFY

LDSMSH:	MOVE T,(AR2A)
	LSH T,-33		;T GETS THE CALL UUO OPCODE
	CAIL T,CALL←-33
	 CAILE T,CALL←-33+NUUOCLS
	  POPJ P,		;RETURN IF NOT REALLY A CALL
	HRRZ A,(AR2A)
	MOVEI B,SBRL
	PUSHJ P,GETLA		;TRY TO GET SUBR, FSUBR, OR LSUBR PROP
	LDB D,[270400,,(AR2A)]
	JUMPE A,LDSMNS		;JUMP IF NOT ANY OF THOSE
	HLRZ B,(A)
	HRRZ T,(AR2A)
	HLRZ T,(T)
	HLRZ T,1(T)		;GET ARGS PROPERTY FOR FUNCTION NAME
	SOJL T,LDZA2		;JUMP IF THERE ISN'T ANY
	CAIG T,NACS		;ARGS PROPERTY IS SCREWY IF THIS SKIPS!
	 TLOA T,(CAIE D,)	;IF ARGS PROP OK, TEST FOR THAT EXACT NUMBER OF ARGS IN UUO
LDZA2:	  MOVE T,[CAILE D,NACS]	;IF NO OR BAD ARGS PROP, JUST CHECK FOR RANGE
	CAIN B,QFSUBR
	 MOVE T,[CAIE D,17]
	CAIN B,QLSUBR
	 MOVE T,[CAIE D,16]
	XCT T			;AC FIELD OF CALL IS 0-5 FOR SUBRS, 16 LSUBR, 17 FSUBR
	 JRST POPJ1		;SKIP RETURN IF CALL DOESN'T MATCH FUNCTION TYPE OR # ARGS
	HRRZ A,(A)		;ELSE WIN - SMASH THE CALL
	HLRZ A,(A)		;SUBR ADDRESS NOW IN A
	SKIPA TT,(AR2A)
LDZAOK:	 HRLI A,(@)		.SEE ASAR
	MOVSI T,(PUSHJ P,)	;CALL BECOMES PUSHJ
	TLNE TT,20000
	 ADDI A,1		;HACK NCALLS CORRECTLY - ENTER AT ROUTINE+1
	TLNE TT,1000
	 MOVSI T,(JRST)		;JCALL BECOMES JRST
LDZA1:	IOR T,A
	MOVEM T,(AR2A)		;***SMASH!***
	POPJ P,

LDSMNS:	HRRZ A,(AR2A)		;TRY TO GET ARRAY PROPERTY
	MOVEI B,QARRAY
	PUSHJ P,GET
	MOVEI T,(A)
	LSH T,-SEGLOG
	MOVE T,ST(T)
	TLNN T,SA
	 JRST POPJ1		;LOSE IF NOT SAR
	LDB T,[TTSDIM,,TTSAR(A)]
	CAIE T,(D)		;MUST HAVE CORRECT NUMBER OF ARGS
	 JRST POP1J
	MOVSI T,TTS<CN>
	IORM T,TTSAR(A)		;SET "COMPILED-CODE-NEEDS-ME" BIT IN SAR
	MOVE TT,(AR2A)
	TLNN TT,20000
	 JRST LDZAOK
	MOVSI T,(ACALL)		;FOR AN NCALL-TYPE UUO, SMASH IT TO
	TLNE TT,1000		; BE A CROCKISH ACALL OR AJCALL
	 MOVSI T,(AJCALL)
	JRST LDZA1


SUBTTL	GETDDTSYM HACKERY

LDGET:	CAMN TT,XC-1
	 JRST LDLHRL
	MOVE D,TT		;[GET DDT SYMBOL PATCH]
	TLNN D,200000		;MAYBE THE ASSEMBLER LEFT US A VALUE?
	 JRST LDGET2
	JSP T,LDGTWD		;FETCH IT THEN
	SKIPE LDF2DP
	 JRST LDGET2		;CAN'T USE IT IF VERSIONS DIFFER
LDGET1:	TLNE D,400000		;MAYBE NEGATE SYMBOL?
	 MOVNS TT
	LDB D,[400200,,D]	;GET FIELD NUMBER
	XCT LDXCT(D)		;HASH UP VALUE FOR FIELD
	MOVE T,LDMASK(D)	;ADD INTO FIELD
	ADD TT,-1(R)		; MASKED APPROPRIATELY
	AND TT,T
	ANDCAM T,-1(R)
	IORM TT,-1(R)
	JRST LDBIN

LDGET2:	UNLOCKI			;UNLOCK INTERRUPTS
	PUSH FXP,.		;RANDOM FXP SLOT
	PUSH FXP,AR1		;SAVE UP ACS
	PUSH FXP,D
	PUSH FXP,R
	PUSH FXP,F
	MOVEI R,0
	TLZ D,740000
REPEAT LOG2LL5,[
	CAML D,LAPFIV+<1←<LOG2LL5-.RPCNT-1>>(R)
	 ADDI R,1←<LOG2LL5-.RPCNT-1>
]		;END OF REPEAT LOG2LL5
	CAME D,LAPFIV(R)	;IF DDTSYM REQUEST IS FOR A GLOBAL SYM
	 JRST LDGT5A		;THEN FIND IT IN THE LAPFIV TABLE, AND GET ITS 
	LSHC R,-2		;GLOBALSYM INDEX FROM THE PERMUTATION TABLE
	LSH F,-42
	LDB TT,LDGET6(F)
	MOVE TT,LSYMS(TT)
	JRST LDGT5B
LDGT5A:	MOVEI TT,R70
	CAMN D,[SQUOZE 0,R70]
	 JRST LDGT5B
	PUSHJ P,UNSQOZ		;CONVERT SQUOZE TO A LISP SYMBOL
	MOVEI C,(A)
	MOVEI B,QSYM		;TRY TO FIND SYM PROPERTY
	PUSHJ P,GET
	JUMPN A,LDGETJ		;WIN
IFN ITS,[
	JSP T,SIDDTP		;MAYBE WE CAN GET VALUE FROM DDT?
	 JRST LDGETX
	LDB T,[004000,,-2(FXP)]
	.BREAK 12,[..RSYM,,T]
	JUMPE T,LDGETX		;LOSE, LOSE, LOSE
]		;END OF IFN ITS
IFN D10,[
	SKIPN .JBSYM"
	 JRST LDGETX
	LDB D,[004000,,-2(FXP)]
LDGET4:	MOVE TT,D
	IDIVI D,50
	JUMPE R,LDGET4
	PUSHJ P,GETDD0
	JRST LDGETX
]		;END OF IFN D10
LDGT5B:	MOVEM TT,-4(FXP)	;WIN, WIN - USE RANDOM FXP SLOT
	MOVEI A,-4(FXP)		; TO FAKE UP A FIXNUM
	JRST LDGETJ

LDGETX:	MOVEI A,(C)
	PUSHJ P,NCONS
	MOVEI B,QGETDDTSYM	;DO A FAIL-ACT
	PUSHJ P,XCONS
	PUSHJ P,LDGETQ
LDGETJ:	POP FXP,F		;RESTORE ACS
	POP FXP,R
	POP FXP,D
	POP FXP,AR1
	PUSHJ P,LDLRSP		;LOCKI AND RESTORE ARRAY POINTERS
	MOVE TT,(A)
	PUSHJ P,TYPEP		;FIGURE OUT WHAT WE GOT BACK
	POP FXP,-1(FXP)		;POP RANDOM SLOT (REMEMBER THE LOCKI!)
	CAIN A,QFIXNUM
	JRST LDGET1
LDGETV:	CAIN A,QFLONUM		;USE A FLONUM IF WE GET ONE
	JRST LDGET1
LDGETW:	PUSHJ P,LDGDDT		;FOR ANYTHING ELSE TRY DDT AGAIN
	MOVEM TT,LDDDTP(P)
	JRST LDGET2


LDGET6: REPEAT 4,[<11←24.>+<<<3-.RPCNT>*11>←30.> LAP5P(R)
]

IFN ITS,[
LDGDDT:	JSP T,SIDDTP
	 JRST ZPOPJ		;0 => TOP LEVEL, OR NOT INFERIOR TO DDT
	.BREAK 12,[..RSTP,,TT]	;-1,,0 => INFERIOR TO DDT, BUT NO SYMBOL TABLE
	SKIPN TT		;1,,0 => INFERIOR TO DDT WITH SYMBOL TABLE
	 TLOA TT,-1
	  MOVSI TT,1
	POPJ P,
]		;END OF IFN ITS

IFN D20,[
LDGDDT==:ZPOPJ			;FOR NOW, NEVER A DDT
]		;END IFN D20


IFN D10,[
LDGDDT:	SKIPE TT,.JBSYM"
	 MOVSI TT,1
	POPJ P,
]		;END OF IFN D10

LDXCT:	MOVSS TT	;INDEX FIELD
	HRRZS TT	;ADDRESS FIELD
	LSH TT,23.	;AC FIELD
	JFCL		;OPCODE FIELD

LDMASK:	-1		;INDEX FIELD
	0,,-1		;ADDRESS FIELD
	0 17,		;AC FIELD
	-1		;OPCODE FIELD

LDLHRL:	HRLZ TT,LDOFST
	ADDM TT,-1(R)
	JRST LDBIN

SUBTTL	ARRAY, GLOBALSYM, AND ATOMTABLE ENTRY STUFF

LDAREF:	PUSH FXP,TT		;[ARRAY REFERENCE]
	MOVE D,@LDAPTR
	TLNN D,777001
	 TLO D,11
	MOVEM D,@LDAPTR
	TRNN D,-1
	 JRST LDARE1		;SKIP IF HACKING 'NIL'
	TLNE D,777000		;IF NO VC THEN MUST HACK SYMBOL
	 JRST LDARE1
	HLRZ T,(D)
	HLL T,(T)
	TLO T,SY.CCN\SY.OTC	;COMPILED CODE NEEDS, OTHER THAN CALL REF
	TLNN T,SY.PUR		;CAN'T WRITE IF PURE
	 HLLM T,(T)
LDARE1:	MOVEI A,(D)
	PUSHJ P,TTSR+1		;NCALL TO TTSR
	HLL TT,(FXP)
	SUB FXP,R70+1
	JRST LDABS


LDGLB:	SKIPL TT		;[GLOBALSYM PATCH]
	 SKIPA TT,LSYMS(TT)	;GET VALUE OF GLOBAL SYMBOL
	  MOVN TT,LSYMS(TT)	;OR MAYBE NEGATIVE THEREOF
	ADD TT,-1(R)		;ADD TO ADDRESS FIELD OF
	HRRM TT,-1(R)		; LAST WORD LOADED
	JRST LDBIN

LDATM:	LDB T,[410300,,TT]	;[ATOMTABLE ENTRY]
	JRST LDATBL(T)

LDATBL:	JRST LDATPN		;PNAME
	JRST LDATFX		;FIXNUM
	JRST LDATFL		;FLONUM
BG$	JRST LDATBN		;BIGNUM
BG%	JRST LDATER
DB$	JRST LDATDB		;DOUBLE
DB%	JRST LDATER
CX$	JRST LDATCX		;COMPLEX
CX%	JRST LDATER
DX$	JRST LDATDX		;DUPLEX
DX%	JRST LDATER
	.VALUE			;UNDEFINED

LDATPN:	MOVEI D,(TT)		;[ATOMTABLE PNAME ENTRY]
	PUSH FXP,R
	CAILE D,LPNBUF
	 JRST LDATP2
	MOVEI C,PNBUF-1
LDATP1:	JSP T,LDGTWD
	ADDI C,1
	MOVEM TT,(C)
	SOJG D,LDATP1
	SETOM LPNF
	JRST LDATP4

LDATP2:	PUSH FXP,D
LDATP3:	JSP T,LDGTWD
	JSP T,FWCONS
	PUSH P,A
	SOJG D,LDATP3
	POP FXP,T
	MOVNS T
	PUSHJ FXP,LISTX
	SETZM LPNF
LDATP4:	PUSH FXP,AR1
	PUSHJ P,RINTERN
	POP FXP,AR1
	POP FXP,R
LDATP8:	MOVE TT,LDAAOB
	MOVEM A,@LDAPTR
	AOBJP TT,LDAEXT
	MOVEM TT,LDAAOB
	JRST LDBIN

LDATFX:	JSP T,LDGTWD		;[ATOMTABLE FIXNUM ENTRY]
	PUSH FXP,TT
	MOVEI A,(FXP)
	PUSH P,AR1
	PUSHJ P,GCLOOK
	POP P,AR1
	POP FXP,TT
	SKIPE A
LDATX0:	 TLOA A,10
	  JRST LDATX2
LDATX1:	TLO A,2
	JRST LDATP8

LDATX2:	SKIPE V.PURE
	 JRST LDATX3
	JSP T,FXCONS
	JRST LDATX1
LDATX3:	PUSHJ P,PFXCONS
	JRST LDATX0

LDATFL:	JSP T,LDGTWD		;[ATOMTABLE FLONUM ENTRY]
	PUSH FLP,TT
	MOVEI A,(FLP)
	PUSH P,AR1
	PUSHJ P,GCLOOK
	POP P,AR1
	POP FLP,TT
	SKIPE A
LDATL0:	 TLOA A,10
	  JRST LDATL2
LDATL1:	TLO A,4
	JRST LDATP8

LDATL2:	SKIPE V.PURE
	 JRST LDATL3
	JSP T,FLCONS
	JRST LDATL1
LDATL3:	PUSHJ P,PFLCONS
	JRST LDATL0

IFN BIGNUM,[
LDATBN:	PUSH FXP,TT		;[ATOMTABLE BIGNUM ENTRY]
	MOVEI D,(TT)
	MOVEI B,NIL
LDATB1:	JSP T,LDGTWD
	SKIPE V.PURE
	 JRST LDATB2
	JSP T,FWCONS
	PUSHJ P,CONS
	JRST LDATB3

LDATB2:	PUSHJ P,PFXCONS
	PUSHJ P,PCONS
LDATB3:	MOVE B,A
	SOJG D,LDATB1
	POP FXP,TT
	TLNE TT,1
	 TLO A,-1
	SKIPE V.PURE
	 JRST LDATB6
	PUSHJ P,BNCONS
	JRST LDATB7

LDATB6:	PUSHJ P,PBNCONS
	TLO A,10
LDATB7:	TLO A,6
	JRST LDATP8
]		;END OF IFN BIGNUM

LDAEXT:	MOVE T,TT		;[ATOMTABLE EXTEND]
	HRLI T,-ILDAT
	MOVEM T,LDAAOB
	ADDI TT,ILDAT
	ASH TT,1
	UNLOCKI		.SEE ERROR5	;.REARRAY MAY PULL AN ERINT
	PUSH FXP,AR1
	PUSH FXP,R
	PUSH FXP,F
	PUSH P,[LDRFRF]
	PUSH P,LDASAR
	PUSH P,[TRUTH]
	PUSH FXP,TT
	MOVEI A,(FXP)
	PUSH P,A
	MOVNI T,3
	JRST .REARRAY
LDRFRF:	SUB FXP,R70+1		;[RETURN FROM .REARRAY FUNCTION]
	POP FXP,F
	POP FXP,R
	POP FXP,AR1
	PUSHJ P,LDLRSP
	JRST LDBIN

SUBTTL	ENTRY POINT

LDENT:	HRRZ C,@LDAPTR		;[ENTRY POINT INFO]
	MOVSS TT
	HRRZ A,@LDAPTR
	PUSH P,A
	PUSH P,C
	SKIPN B,VFASLOAD
	 JRST LDNRDF
	CAIN B,TRUTH		;IF C(FASLOAD) IS T
	 MOVEI B,SBRL		;THEN USE (SUBR LSUBR FSUBR)
	HRRZ A,(P)		;IS PROPERTY BEING DEFINED ONE OF INTEREST?
	PUSHJ P,MEMQ
	JUMPE A,LDNRDF		;NOPE, SO PRINT NO MESSAGES
	MOVE B,VFASLOAD
	CAIN B,TRUTH		;IF C(FASLOAD) IS T
	 MOVEI B,SBRL		;THEN USE (SUBR LSUBR FSUBR)
	HRRZ A,-1(P)		;ATOM THAT IS BEING HACKED
	PUSHJ P,GETL		;DID THIS PREVIOUSLY HAVE A PROP OF INTEREST?
	JUMPE A,LDNRDF		;NOPE, NO MESSAGES TO BE PRINTED
	PUSH P,A
	PUSH FXP,AR1
	PUSH FXP,R
	PUSH FXP,F
Q%	PUSHJ P,IOGBND
Q$	MOVEI A,TRUTH
Q$	JSP T,SPECBIND
Q$	   0 A,V%TERPRI
	STRT 17,[SIXBIT \↑M;CAUTION#!  !\]
	MOVE A,-2(P)
Q%	PUSHJ P,PRIN1
Q$	PUSHJ P,MSGFCK
Q$	TLO AR1,200000
Q$	PUSHJ P,$PRIN1		;SAVES AR1
	HRRZ B,@(P)
	HLRZ B,(B)
	MOVEI TT,[SIXBIT \, A SYSTEM !\]
10%	CAIL B,ENDFUN
10$	CAIGE B,BEGFUN
	 MOVEI TT,[SIXBIT \, A USER !\]
	STRT 17,(TT)
	HLRZ A,@(P)
Q%	PUSHJ P,PRIN1
Q$	PUSHJ P,$PRIN1		;AR1 IS STILL GOOD
	HRRZ TT,@(P)
	HLRZ TT,(TT)
	MOVEI T,(TT)
	LSH T,-SEGLOG
	HRRZ T,ST(T)
	CAIE T,QRANDOM
	 JRST LDENT4
	STRT 17,[SIXBIT \ AT !\]	;USE OF PRINL4 HERE DEPENDS ON PRIN1
	PUSHJ P,PRINL4			; LEAVING ADDRESS OF TYO IN R (AND FILES IN AR1)
LDENT4:	STRT 17,[SIXBIT \, IS BEING REDEFINED↑M;    AS A !\]
	HRRZ A,-1(P)
Q%	PUSHJ P,PRIN1
Q$	PUSHJ P,$PRIN1
	STRT 17,[SIXBIT \ BY FASL FILE !\]
	MOVE A,LDFNAM
Q%	PUSHJ P,PRIN1
Q$	PUSHJ P,$PRIN1
Q%	PUSHJ P,TERPRI
Q$	PUSHJ P,TERP1
	PUSHJ P,UNBIND
	POP FXP,F
	POP FXP,R
	POP FXP,AR1
	SUB P,R70+1
LDNRDF:	MOVE B,(P)
	MOVE A,-1(P)
	PUSHJ P,REMPROP
	POP P,C
	MOVE A,(P)
	JSP T,LDGTWD
	PUSH FXP,TT
	MOVEI B,@LDOFST
	CAILE B,(R)
	 JSP D,LDFERR
	PUSHJ P,PUTPROP
	POP FXP,TT
	HLRZ T,TT
	HLRZ B,@(P)
	HLRZ D,1(B)
	CAIN D,(T)			;NEEDN'T DO IT IF ALREADY SAME
	 JRST LDPRG3
LDPARG:					;ELSE TRY TO CLOBBER IT IN
PURTRAP LDPRG9,B,	HRLM T,1(B)
LDPRG3:	SUB P,R70+1
	JRST LDBIN

SUBTTL	PUTDDTSYM FROM FASL FILE

;;; THE WORD IN TT HAS SQUOZE FOR DEFINED SYMBOL, PLUS FOUR BITS:
;;;	4.9	1 => FOLLOWING WORD IS VALUE, 0 => LOAD LOC IS VALUE
;;;	4.8	LH IS RELOCATABLE
;;;	4.7	RH IS RELOCATABLE
;;;	4.6	IS GLOBAL (0 => SYMBOLS = 'T LOADS, BUT = 'SYMBOLS DOES NOT)

IFN ITS,[
LDPUT:	SKIPN A,V$SYMBOLS
	 JRST LDPUT3		;FORGET IT IF SYMBOLS NOT NON-NIL
	CAIE A,Q$SYMBOLS
	 JRST LDPUT7
	TLNN TT,40000		;IF HAS 'SYMBOLS, LOAD ONLY GLOBALS
	 JRST LDPUT3
LDPUT7:	JUMPL TT,LDPUT2
	MOVEI D,(R)
LDPUT0:	TLZ TT,740000
	TLO TT,%SYGBL
	SKIPG A,LDDDTP(P)
	 JRST LDBIN		;FORGET IT IF DDT HAS NO SYMBOL TABLE
	MOVE T,TT
	TRNE A,-1		;MAY HAVE TO CREATE SYMBOL TABLE ARRAY
	 JRST LDPUT5
	UNLOCKI
	PUSH FXP,AR1
	PUSHJ P,SAVX5
	MOVEI TT,LLDSTB*2+1
	MOVSI A,-1
	PUSHJ P,MKFXAR
	PUSHJ P,RSTX5
	POP FXP,AR1
	PUSHJ P,LDLRSP
	HRRM A,LDDDTP(P)
LDPUT4:	MOVSI TT,-LLDSTB	;USE TT FOR TWO THINGS HERE!
	MOVEM TT,@TTSAR(A)
LDPUT5:	SETZ TT,
	AOS TT,@TTSAR(A)	;GET AOBJN POINTER
	JUMPGE TT,LDPUT4
	MOVEM T,@TTSAR(A)	;SAVE SQUOZE FOR SYMBOL
	ADD TT,R70+1
	MOVEM D,@TTSAR(A)	;SAVE ITS VALUE
	MOVE T,TT
	SETZ TT,
	MOVEM T,@TTSAR(A)	;SAVE BACK INCREMENTED AOBJN PTR
	JUMPL T,LDBIN
	PUSHJ P,LDPUTM		;MAY BE TIME TO OUTPUT BUFFER
	JRST LDBIN

LDPUTM:	SETZ TT,
	MOVN T,@TTSAR(A)
	MOVSI T,(T)
	HRR T,TTSAR(A)
	AOSGE T
	 .BREAK 12,[..SSTB,,T]
	POPJ P,
]		;END OF IFN ITS

IFN D10,[
LDPUT:	SKIPN A,V$SYMBOLS
	 JRST LDPUT3
	CAIE A,Q$SYMBOLS
	 JRST LDPUT7
	TLNN TT,40000
	 JRST LDPUT3
LDPUT7:	SKIPN .JBSYM"
	 JRST LDPUT3
	PUSH FXP,AR1
	JUMPL TT,LDPUT2
	MOVE D,R
LDPUT0:	PUSH FXP,D
	PUSH FXP,F
	TLZ TT,740000
LDPUT1:	MOVE T,TT
	IDIVI TT,50
	JUMPE D,LDPUT1
	MOVEI B,-1(FXP)
	MOVSI R,400000
	PUSHJ P,PUTDD0
	POP FXP,F
	SUB FXP,R70+1
	POP FXP,R
	POP FXP,AR1
	JRST LDBIN
]		;END OF IFN D10

LDPUT2:	MOVE D,TT
	JSP T,LDGTWD
	EXCH TT,D
	TLNN TT,100000
	 JRST LDPT2A
	MOVE T,LDOFST
	ADD T,D
	HRRM T,D
LDPT2A:	TLNN TT,200000
	 JRST LDPT2B
	HRLZ T,LDOFST
	ADD D,T
LDPT2B:	TLZ T,740000
	TLO T,%SYGBL+%SYHKL	;GLOBAL AND HALF-KILLED
	JRST LDPUT0

20$ WARN [WHAT TO DO ABOUT TOPS-20 LDPUT]
20$ LDPUT:
LDPUT3:	JUMPGE TT,LDBIN		;DON'T WANT TO PUT DDT SYM, BUT
	JSP T,LDGTWD		; MAYBE NEED TO FLUSH EXTRA WORD
	JRST LDBIN


LDLOC:	MOVEI TT,@LDOFST
	MOVEI D,(R)
	CAMLE D,LDHLOC
	 MOVEM D,LDHLOC
	CAMG TT,LDHLOC
	 JRST LDLOC5
	MOVE D,LDHLOC
	SUBI D,(R)
	MOVSI D,(D)
	ADD R,D
	HRR R,LDHLOC
	SETZ TT,
	SUB F,R70+1		;BEWARE THIS BACK-UP CROCK!
	ADD AR1,[040000,,]
	JRST LDABS

LDLOC5:	HRRZ D,LDOFST
	CAIGE TT,(D)
	 JSP D,LDFERR
	MOVEI D,(TT)
	SUBI D,(R)
	MOVSI D,(D)
	ADD R,D
	HRRI R,(TT)
	JRST LDBIN


SUBTTL	EVALUATE MUNGEABLE

LDEVAL:	SETZ D,			;[EVALUATE MUNGEABLE]
	PUSHJ P,LDLIST		;IF D IS LEFT 0 AFTER LDLIST, THEN WANT ENTRY INTO ATOMTABLE
	MOVEI B,(P)		;B HAS ADDR OF FASLOAD TEMPS ON STACK
	PUSH P,A
	PUSHJ P,LDEV0
	SUB P,R70+1
	JUMPN D,LDBIN
	JSP T,LDQLPRO		;PUSHES GOODY ONTO THE LDEVPRO LIST
LDEVL7:	TLO A,16		;AND GOES OFF TO ENTER INTO THE ATOMTABLE
	JRST LDATP8


LDEV0:	UNLOCKI			;EVALUATES AN S-EXPRESSION IN A
IFN QIO,[
	JUMPE D,LDEV2		;IN QIO, ALLOWS FOR RECURSIVE FASLOADING
	SETZM FASLP		;EXCEPT WHEN EVALUATING FOR ENTRY INTO ATOMTABLE
	PUSH P,A
	MOVE C,LDPRLS(B)
	TLNN C,600000
	 HRRZM C,VPURCLOBRL
IFN D10,[
	TLNN C,100000
	 JRST LDEV4
	HRRZM R,HBPORG
	JRST LDEV5
LDEV4:
]		;END OF IFN D10
	MOVEI TT,(R)
	JSP T,FXCONS
	MOVEM A,VBPORG
LDEV5:	HRRZ TT,LDOFST		;IN CASE EVALUATION CHANGES BPORG,
	SUBI TT,(R)		; MUST CHANGE LDOFST TO BE AN
	HRRM TT,LDOFST		; ABSOLUTE QUANTITY
	MOVNI T,LFTMPS
	PUSH FXP,BFTMPS+LFTMPS(T)
	AOJL T,.-1
	POP P,A
LDEV2:
]		;END OF IFN QIO
	PUSH FXP,B
	PUSH FXP,AR1
	PUSH FXP,D
	PUSH FXP,R
	PUSH FXP,F
	PUSHJ P,EVAL
	POP FXP,F
	POP FXP,R
	POP FXP,D
	POP FXP,AR1
	POP FXP,B
IFN QIO,[
	JUMPE D,LDEV1
10$	MOVE C,LDPRLS(B)
10$	TLNE C,100000
10$	 SKIPA R,HBPORG
	  MOVE R,@VBPORG
	HRRZ T,LDBGEN(B)
	MOVEM T,FASLP
	MOVEI T,LFTMPS-1
	POP FXP,BFTMPS(T)
	SOJGE T,.-1
	HRRZ TT,LDOFST		;NOW RE-RELOCATE THE LOAD OFFSET
	ADDI TT,(R)
	HRRM TT,LDOFST
	HRRZ T,VPURCLOBRL
	HRRM T,LDPRLS(B)
]		;END OF IFN QIO
LDEV1:	PUSH P,A
10$	MOVE TT,LDPRLS(B)	;FOR D10, PASS LDPRLS IN TT TO LDGTSP
	PUSHJ P,LDGTSP
	POP P,A
	JRST LDLRSP		;GET SPACE, LOCKI, AND RESTORE PTRS

SUBTTL	END OF FASLOAD FILE


LDBEND:	TRZ TT,1		;CROCK!
	CAME TT,[SIXBIT \*FASL*\]
	 JSP D,LDFERR
	MOVEI TT,LDFEND
	MOVEM TT,LDEOFJ
IFN ITS,[
	SKIPLE A,LDDDTP(P)
	 TRNN A,-1
	  CAIA
	   PUSHJ P,LDPUTM	;MAYBE HAVE TO FORCE LDPUT'S BUFFER
]		;END OF IFN ITS
	HLLZS LDDDTP(P)		;WILL USE FOR SWITCH LATER
	JSP T,LDGTWD
	TRZ TT,1		;COMPATIBILITY CROCK
	CAME TT,[SIXBIT \*FASL*\]
	 JRST LDBEN1
	HLLOS LDDDTP(P)
	MOVEM F,LDTEMP
	JRST LDFEND

LDBEN1:	TRZ TT,1
	CAME TT,[14060301406]
10%	 JSP D,LDFERR
10$	 JUMPN TT,LDFERR
LDFEND:	TLZ R,-1		;END OF FILE
	CAMGE R,LDHLOC
	 MOVE R,LDHLOC
	HRRZS TT,R
IFN D10,[
	MOVE C,LDPRLS(P)
	TLNN C,100000
	 JRST LDFEN2
	HRRZM R,HBPORG
	JRST LDFEN3

LDFEN2:	JSP T,FXCONS
	MOVEM A,VBPORG
LDFEN3:
]		;END OF IFN D10
IFN ITS+D20,[
	JSP T,FXCONS
	MOVE D,(A)
	EXCH A,VBPORG
	MOVE TT,(A)
	SKIPL LDPRLS(P)
	 JRST LDZPUR
	HLLOS NOQUIT
	ANDI TT,PAGMSK
	ANDI D,PAGMSK
	LSHC TT,-PAGLOG
	SUBI D,(TT)
	ROT TT,-4
	ADDI TT,(TT)
	ROT TT,-1
	TLC TT,770000
	ADD TT,[450200,,PURTBL]
	MOVEI T,1
LDNPUR:	TLNN TT,730000
	 TLZ TT,770000
	IDPB T,TT
	SOJGE D,LDNPUR
	PUSHJ P,CZECHI
LDZPUR:
]		;END OF IFN ITS+D20
;FALLS THROUGH

;FALLS IN

	PUSH FXP,F		;SAVE POINTER TO I/O BUFFER
	HRRZ F,LDAAOB
LDGCPR:	SOJLE F,LDSDPL		;[GC PROTECT AS YET UNPROTECTED ATOMS]
	SKIPE INTFLG
	 PUSHJ P,LDTRYI
	MOVEI TT,(F)
	MOVE AR2A,@LDAPTR
	HRRZ A,AR2A
	JUMPE A,LDGCPR		;LOSING MIDAS!
	TLNE AR2A,777000	;WAS VALUE CELL CREATED BY FASLOAD?
	 JRST LDGCPR		;YES, THEN NO NEED TO HACK IT AT ALL
	TLNN AR2A,6
	 JRST LDGCPR		;NOT NUMBER, HACKED ALREADY
	TLNN AR2A,10
	 TLNN AR2A,1
	  JRST LDGCPR
LDGCP1:	HRRZ A,AR2A
	CAIGE A,IN0+XHINUM
	 CAIGE A,IN0-XLONUM
	  CAIA
	   JRST LDGCPR
;IF FOR SOME REASON, THIS CAUSES THE CREATION OF THE GCPSAR
; I STILL DONT THINK WE NEED TO RESTORE PTRS HERE.
;I DISAGREE, SO I'M STICKING IN A CALL TO LDRSPT - GLS
	PUSHJ P,%GCPRO
	PUSHJ P,LDRSPT
	JRST LDGCPR

SUBTTL	SMASH DOWN PURE LIST

LDSDPL:	SKIPL TT,LDPRLS(P)	;[SMASH DOWN PURE LIST]
	 TLNE TT,200000
	  JRST LDEOMM
	MOVEM TT,VPURCLOBRL
	MOVEI F,VPURCLOBRL
LDSDP1:	SKIPN TT,LDPRLS(P)
	 JRST LDEOMM
	SKIPN INTFLG
	 JRST LDSDP2
	SKIPE INTFLG
	 PUSHJ P,LDTRYI
LDSDP2:	HRRZ T,(TT)
	MOVEM T,LDPRLS(P)
	HLRZ AR2A,(TT)
	PUSHJ P,LDSMSH
	 JRST LDSDP3
	HRRZ F,(F)
	JRST LDSDP1
LDSDP3:	MOVE TT,LDPRLS(P)
	HRRM TT,(F)
	JRST LDSDP1

SUBTTL	END OF FASLOAD, AND RANDOM ROUTINES

LDEOMM:	POP FXP,LDTEMP		;GET POINTER TO I/O BUFFER
	MOVE TT,LDDDTP(P)
Q$	MOVE A,LDBGEN(P)
10$	MOVE C,LDPRLS(P)
	POPI P,LDNPDS		;[END OF MOBY MESS!!!]
	TRNE TT,-1
	 JRST LDEOM1
Q$	PUSHJ P,$CLOSE		;CLOSE FILE ARRAY
Q% 10%	.CLOSE DSIC,
Q% 10$	RELEASE DSIC,
	SETZM LDBSAR
	MOVE A,VBPORG
10$	MOVE TT,HBPORG
10$	TLNE C,100000
10$	 JSP T,FXCONS
	UNLOCKI
	PUSHJ P,UNBIND
	HRRZ TT,-2(P)		;FOR DEBUGGING PURPOSES,
	HRRZ D,-1(P)		; MAKE SURE PDLS ARE OKAY
	HRRZ R,(P)
	SUB P,R70+3
	JRST PDLCHK

LDEOM1:	UNLOCKI
Q$	PUSH P,A		;PUT LDBSAR BACK ON PDL
	JRST LDDISM


LDTRYI:	UNLOCKI			;[TRY AN INTERRUPT]
LDLRSP:	LOCKI			;[LOCKI AND RESTORE POINTERS]
LDRSPT:	HRRZ TT,LDASAR		;[RESTORE ARRAY POINTERS]
	HRRZ TT,TTSAR(TT)
	HRRM TT,LDAPTR
	HRRZ TT,LDBSAR
IFE QIO*D10,[
	HRRZ TT,TTSAR(TT)
	HRRM TT,LDBPTR
]	;END IFE QIO*D10
.ELSE	HLLZS LDBPTR
	POPJ P,

LDLIST:	MOVEI C,-1(P)		.SEE LDOWL
	JRST LDLIS1

LDLIS0:	JSP T,LDGTWD
LDLIS1:	LDB T,[410300,,TT]	;[CONSTRUCT LIST]
	JRST LDLTBL(T)

LDLTBL:	JRST LDLATM		;ATOM
	JRST LDLLST		;LIST
	JRST LDLDLS		;DOTTED LIST
	JRST LDOWL		;EVALUATE TOP FROB ON STACK
IFN HNKLOG, JRST LDLHNK		;HUNK
.ELSE	JRST FASHNE
REPEAT 2, .VALUE
	JRST LDLEND		;END OF LIST

LDLATM:	MOVE A,@LDAPTR		;FOR ATOM, MAYBE SET USAGE BIT,
	TLNN A,777011		; THEN SHOVE ON STACK
	 IOR A,D
	MOVEM A,@LDAPTR
	PUSH P,A
	TRNN A,-1
	 JRST LDLIS0		;SKIP SY2 CHECK IF SYMBOL 'NIL'
	TLNN A,777006		;IF HAS VALUE CELL, OR IS NUMBER, DON'T DO SY2
	 TLNN D,1		;IF SETTING USAGE BIT THEN ALSO DO SO IN SY2
	  JRST LDLIS0
	HLRZ T,(A)		;GET SY2 WORD
	HLL T,(T)
	TLO T,SY.CCN\SY.OTC	;MUST FLAG ATOM AS NEEDED
	TLNN T,SY.PUR		;SET MEMORY UNLESS PURIFIED
	 HLLM T,(T)
	JRST LDLIS0

LDLLST:	TDZA A,A		;FOR LIST, USE NIL AS END
LDLDLS:	POP P,A			;FOR DOTTED LIST, USE TOP ITEM
	HRRZS TT
	JUMPE TT,LDLLS3
LDLLS1:	POP P,B			;NOW POP N THINGS AND CONS THEM UP
	PUSHJ P,XCONS
	SOJG TT,LDLLS1
LDLLS3:	PUSH P,A
	SKIPE INTFLG
	 PUSHJ P,LDTRYI
	JRST LDLIS0

LDOWL:	MOVE A,(P)
	MOVEI B,(C)		;B HAS ADDR OF FASLOAD TEMPS ON STACK
	PUSH P,C
	PUSHJ P,LDEV0
	POP P,C
	MOVEM A,(P)
	JRST LDLIS0

IFN HNKLOG,[
LDLHNK:	MOVEI T,-1(TT)
	JSP AR2A,HUNKF0		;SAVES C
	PUSH P,A
	JRST LDLIS0
]		;END OF IFN HNKLOG

LDLEND:	HLRZ D,TT
	TRC D,777776
	TRNE D,777776
	 JSP D,LDFERR
	POP P,A
	MOVSS TT
	HRRI TT,(A)
	POPJ P,

;;; SECOND FILE NAME OF THIS LISP WHEN ASSEMBLED (VERSION NUMBER
;;; THIS LOCATION IS REFERENCED BY FASLAP WHEN CREATING A BINARY
;;; FILE. IT CONTAINS THE VALUE OF .FNAM2 PLUS EXTRA BITS
;;; TO DISTINGUISH SOME CONDITIONAL ASSEMBLY FLAGS.
;;; THE CONTENTS OF THIS LOCATION ARE PRIMARILY USED TO DETERMINE
;;; WHETHER FASLOAD MAY USE VALUES OF DDT SYMBOLS SUPPLIED BY
;;; FASLAP; IT DOES SO ONLY IF FASLAP'S VERSION NUMBER, AS
;;; DETERMINED BY THIS LOCATION, IS THE SAME AS FASLOAD'S.

ZZ==-1
ZZZ==0

;;;  BIBOP USED TO BE THE 3RD NUMBER HERE
IRP X,,[D10,ML,1,BIGNUM,MOBIOF]
ZZ==ZZ←1
ZZZ==<ZZZ←1>\X
TERMIN

LDFNM2:	<.FNAM2&ZZ>\ZZZ

EXPUNGE ZZ ZZZ

IFE QIO,[
LDFNSET:	MOVE A,LDFNAM
	JSP T,LNG1A	;GETS LENGTH OF ARG
	MOVE A,LDFNAM
	CAIN TT,4
	POPJ P,
	CAIGE TT,2
	JRST SCRFUN	;COMPUTES STANDARD FILE SPECIFICATION LIST
	JSP T,%CADR	;FROM INPUT ARG
	MOVE B,IUNIT
	PUSHJ P,CONS
	HLRZ B,@LDFNAM
	JRST XCONS
]		;END OF IFE QIO

IFE QIO,[

LDGTW0:	HRLZI F,-LLDBF		;RESET THE POINTER AND THIS TIME GET A REAL DATA WORD
LDGTWD:	MOVE TT,@LDBPTR		;PICK UP WORD FROM INPUT BUFFER
	AOBJN F,(T)		;RETURN WITH WORD
LDGTW1:	MOVE F,@LDBSAR		.SEE ASAR
	MOVE F,-1(F)		;THAT WAS NO DATA WORD - MUST GET MORE
IFN ITS,[
	ADD F,[1,,]
	MOVE TT,F
	.IOT DSIC,F
	TLNN F,-1		;SKIP IF WE DIDNT GET A WHOLE BUFFERFUL
	 JRST LDGTW0
	CAMN F,TT		;SKIP IF WE GOT AT LEAST ONE WORD
	 JSP D,@LDEOFJ		;OTHERWISE GO CRY A LOT, OR SOMETHING
	HLRES F			;CALCULATE POINTER FOR THE PARTIAL BLOCK
	ADDI F,LLDBF
	MOVNS F
	HRLZS F
	JRST LDGTWD		;NOW GO GET A REAL DATA WORD
]		;END OF IFN ITS
IFN D10,[
	ADDI F,-1	;SIMULTANEOUS +1 IN LH -1 IN RH
	MOVEM F,D10ARD		;SAVE IN I/O LIST
IFN SAIL,[
	PUSH FXP,D
	PUSH FXP,R
	HRRZ D,D10ARD
	AOJ D,			;D10ARD POINTS TO ADDRESS BEFORE
	HRLI D,-1(D)
	AOBJN D,.+1		;CONS UP BLT PTR
	SETZM -1(D)		;ZERO FIRST WORD
	MOVEI R,LLDBF-2(D)	;CALCULATE END-WORD ADDR
	BLT D,(R)		;BLLLLLLLLLLLLLLLLLLLL. . .LLLLLT
	POP FXP,R
	POP FXP,D
]		;END OF IFN SAIL
	IN DSIC,D10ARD
	 JRST LDGTW0
	AOSN LDEOFP		;GETTING EOF FLAG ONCE IS OKAY
	 JRST LDGTW0
	JSP D,@LDEOFJ		;TWICE IS A LOSER
]		;END OF IFN D10
]		;END OF IFE QIO

IFN QIO,[
IFN ITS,[
LDGTW0:	SUB F,FB.BFL(TT)
	HRLZI F,(F)
	HRRI F,FB.BUF
LDGTWD:	MOVE TT,@LDBPTR
	AOBJN F,(T)
LDGTW1:	HRRZ TT,LDBSAR
	HRRZ TT,TTSAR(TT)
	PUSH FXP,FB.IBP(TT)
	MOVE F,FB.BFL(TT)
	SUBI F,1
	.CALL LDGTW9
	 .LOSE 1400
	POPI FXP,1
	ADDI F,1
	CAME F,FB.BFL(TT)
	 SOJA F,LDGTW0
	JSP D,@LDEOFJ

LDGTW9:	SETZ
	SIXBIT \SIOT\		;"STRING" I/O TRANSFER
	      ,,F.CHAN(TT)	;CHANNEL #
	      ,,0(FXP)		;BYTE POINTER
	400000,,F		;BYTE COUNT
];END IFN ITS

IFN D20,[
LDGTW0:	SUB F,FB.BFL(TT)	;MAKE F INTO AOBJN POINTER
	HRLZI F,(F)
	HRRI F,FB.BUF		;POINTING INTO THE BUFFER
LDGTWD:	AOBJP F,LDGTW1
	SUBI F,1		;READJUST TO ACCESS CORRECT WORD
	MOVE TT,@LDBPTR
	AOJA F,(T)		;FIXUP AOBJN POINTER THEN RETURN
LDGTW1:	HRRZ TT,LDBSAR
	HRRZ TT,TTSAR(TT)
	PUSHJ FXP,SAV3		;SAVE ACS WHICH WILL BE DESTROYED
	HRRZ 1,F.JFN(TT)	;JFN INTO AC 1
	MOVE 2,FB.IBP(TT)	;BYTE POINTER INTO AC 2
	MOVN 3,FB.BFL(TT)	;READ THIS MANY BYTES
	SIN			;DO THE INPUT
	ERJMP LDGTWE		;WE CAN IGNORE ERROR IF IT IS EOF
LDGTE1:	MOVN F,3		;GET POSITIVE NUMBER OF BYTES LEFT UNREAD
	PUSHJ FXP,RST3		;RESTORE SAVED ACS
	CAME F,FB.BFL(TT)	;DID WE READ ANYTHING?
	 SOJA F,LDGTW0		;YES, SO EMPTY THE BUFFER BEFORE GIVING EOF
	JSP D,@LDEOFJ

LDGTWE:	MOVEI 1,.FHSLF		;GET OUR LAST ERROR
	GETER
	HRRZS 2			;ONLY WANT ERROR CODE
	CAIN 2,IOX4		;EOF?
	 JRST LDGTE1
	MOVEI 1,.PRIOU		;OUTPUT ERROR TO PRIMARY OUTPUT CHANNEL
	HRLOI 2,.FHSLF		;LAST ERROR FOR OUR PROCESS
	SETZ 3,			;NO LIMIT TO AMOUNT OF OUTPUT
	ERSTR
	 .LOSE			;FAILED
	 .LOSE			;FAILED
	PUSHJ FXP,RST3		;RESTORE SAVED AC'S
	JSP D,@LDEOFJ		;MAKE BELIEVE WE HIT EOF
]		;END IFN D20

IFN D10,[
LDGTW0:	POP P,T
	MOVE TT,FB.HED(TT)	;GET BUFFER HEADER ADDRESS
	MOVN F,2(TT)		;NUMBER OF WORDS IN BUFFER
	HRLZI F,-1(F)
	ADDI F,1		;NOW THE ACTUAL FIRST WORD
LDGTWD:	MOVE TT,LDBSAR		;GET POINTER TO SAR
	HRRZ TT,TTSAR(TT)
	MOVE TT,FB.HED(TT)	;GET POINTER TO BUFFER HEADER
	HRRZ TT,1(TT)		;GET FIRST WORD OF BUFFER - 1
	HRLI TT,F		;INDEXED OFF OF F
	MOVE TT,@TT
	AOBJN F,(T)
LDGTW1:	HRRZ TT,LDBSAR
	HRRZ TT,TTSAR(TT)
	PUSH P,T
	HRLZ T,F.CHAN(TT)	;WE MUST BUILD INSTRUCTION
	LSH T,5			;CHANNEL IN AC FIELD
	TLO T,(IN)		;NOW MAKE IT AN INSTRUCTION
	XCT T			;GET AS MANY WORDS AS POSSIBLE
	 JRST LDGTW0		;IF SUCCESS THEN SETUP NEW POINTERS
	POP P,T
	JSP D,@LDEOFJ
]	;END IFN D10
]		;END OF IFN QIO

PGTOP FSL,[FASLOAD]